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-2008, 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
: constant Fd_Set_Access
:=
48 New_Socket_Set
(No_Fd_Set_Access
);
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 SOSC.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 Unknown_System_Error
: constant C
.Strings
.chars_ptr
:=
64 C
.Strings
.New_String
("Unknown system error");
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70 -- All these require comments ???
72 function Syscall_Accept
74 Addr
: System
.Address
;
75 Addrlen
: not null access C
.int
) return C
.int
;
76 pragma Import
(C
, Syscall_Accept
, "accept");
78 function Syscall_Connect
80 Name
: System
.Address
;
81 Namelen
: C
.int
) return C
.int
;
82 pragma Import
(C
, Syscall_Connect
, "connect");
84 function Syscall_Ioctl
87 Arg
: Int_Access
) return C
.int
;
88 pragma Import
(C
, Syscall_Ioctl
, "ioctl");
94 Flags
: C
.int
) return C
.int
;
95 pragma Import
(C
, Syscall_Recv
, "recv");
97 function Syscall_Recvfrom
102 From
: Sockaddr_In_Access
;
103 Fromlen
: not null access C
.int
) return C
.int
;
104 pragma Import
(C
, Syscall_Recvfrom
, "recvfrom");
106 function Syscall_Send
108 Msg
: System
.Address
;
110 Flags
: C
.int
) return C
.int
;
111 pragma Import
(C
, Syscall_Send
, "send");
113 function Syscall_Sendto
115 Msg
: System
.Address
;
118 To
: Sockaddr_In_Access
;
119 Tolen
: C
.int
) return C
.int
;
120 pragma Import
(C
, Syscall_Sendto
, "sendto");
122 function Syscall_Socket
125 Protocol
: C
.int
) return C
.int
;
126 pragma Import
(C
, Syscall_Socket
, "socket");
128 function Non_Blocking_Socket
(S
: C
.int
) return Boolean;
129 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean);
137 Addr
: System
.Address
;
138 Addrlen
: not null access C
.int
) return C
.int
141 Val
: aliased C
.int
:= 1;
144 pragma Unreferenced
(Res
);
148 R
:= Syscall_Accept
(S
, Addr
, Addrlen
);
149 exit when SOSC
.Thread_Blocking_IO
151 or else Non_Blocking_Socket
(S
)
152 or else Errno
/= SOSC
.EWOULDBLOCK
;
156 if not SOSC
.Thread_Blocking_IO
157 and then R
/= Failure
159 -- A socket inherits the properties of its server especially
160 -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
161 -- tracks sockets set in non-blocking mode by user.
163 Set_Non_Blocking_Socket
(R
, Non_Blocking_Socket
(S
));
164 Res
:= Syscall_Ioctl
(R
, SOSC
.FIONBIO
, Val
'Unchecked_Access);
165 -- Is it OK to ignore result ???
177 Name
: System
.Address
;
178 Namelen
: C
.int
) return C
.int
183 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
185 if SOSC
.Thread_Blocking_IO
186 or else Res
/= Failure
187 or else Non_Blocking_Socket
(S
)
188 or else Errno
/= SOSC
.EINPROGRESS
194 WSet
: Fd_Set_Access
;
195 Now
: aliased Timeval
;
198 WSet
:= New_Socket_Set
(No_Fd_Set_Access
);
201 Insert_Socket_In_Set
(WSet
, S
);
208 Now
'Unchecked_Access);
212 if Res
= Failure
then
213 Free_Socket_Set
(WSet
);
220 Free_Socket_Set
(WSet
);
223 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
226 and then Errno
= SOSC
.EISCONN
228 return Thin_Common
.Success
;
241 Arg
: Int_Access
) return C
.int
244 if not SOSC
.Thread_Blocking_IO
245 and then Req
= SOSC
.FIONBIO
248 Set_Non_Blocking_Socket
(S
, True);
252 return Syscall_Ioctl
(S
, Req
, Arg
);
261 Msg
: System
.Address
;
263 Flags
: C
.int
) return C
.int
269 Res
:= Syscall_Recv
(S
, Msg
, Len
, Flags
);
270 exit when SOSC
.Thread_Blocking_IO
271 or else Res
/= Failure
272 or else Non_Blocking_Socket
(S
)
273 or else Errno
/= SOSC
.EWOULDBLOCK
;
286 Msg
: System
.Address
;
289 From
: Sockaddr_In_Access
;
290 Fromlen
: not null access C
.int
) return C
.int
296 Res
:= Syscall_Recvfrom
(S
, Msg
, Len
, Flags
, From
, Fromlen
);
297 exit when SOSC
.Thread_Blocking_IO
298 or else Res
/= Failure
299 or else Non_Blocking_Socket
(S
)
300 or else Errno
/= SOSC
.EWOULDBLOCK
;
313 Msg
: System
.Address
;
315 Flags
: C
.int
) return C
.int
321 Res
:= Syscall_Send
(S
, Msg
, Len
, Flags
);
322 exit when SOSC
.Thread_Blocking_IO
323 or else Res
/= Failure
324 or else Non_Blocking_Socket
(S
)
325 or else Errno
/= SOSC
.EWOULDBLOCK
;
338 Msg
: System
.Address
;
341 To
: Sockaddr_In_Access
;
342 Tolen
: C
.int
) return C
.int
348 Res
:= Syscall_Sendto
(S
, Msg
, Len
, Flags
, To
, Tolen
);
349 exit when SOSC
.Thread_Blocking_IO
350 or else Res
/= Failure
351 or else Non_Blocking_Socket
(S
)
352 or else Errno
/= SOSC
.EWOULDBLOCK
;
366 Protocol
: C
.int
) return C
.int
369 Val
: aliased C
.int
:= 1;
372 pragma Unreferenced
(Res
);
375 R
:= Syscall_Socket
(Domain
, Typ
, Protocol
);
377 if not SOSC
.Thread_Blocking_IO
378 and then R
/= Failure
380 -- Do not use C_Ioctl as this subprogram tracks sockets set
381 -- in non-blocking mode by user.
383 Res
:= Syscall_Ioctl
(R
, SOSC
.FIONBIO
, Val
'Unchecked_Access);
384 -- Is it OK to ignore result ???
385 Set_Non_Blocking_Socket
(R
, False);
395 procedure Finalize
is
400 -------------------------
401 -- Host_Error_Messages --
402 -------------------------
404 package body Host_Error_Messages
is separate;
410 procedure Initialize
is
415 -------------------------
416 -- Non_Blocking_Socket --
417 -------------------------
419 function Non_Blocking_Socket
(S
: C
.int
) return Boolean is
423 R
:= (Is_Socket_In_Set
(Non_Blocking_Sockets
, S
) /= 0);
426 end Non_Blocking_Socket
;
428 -----------------------------
429 -- Set_Non_Blocking_Socket --
430 -----------------------------
432 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean) is
436 Insert_Socket_In_Set
(Non_Blocking_Sockets
, S
);
438 Remove_Socket_From_Set
(Non_Blocking_Sockets
, S
);
442 end Set_Non_Blocking_Socket
;
448 package body Signalling_Fds
is separate;
450 --------------------------
451 -- Socket_Error_Message --
452 --------------------------
454 function Socket_Error_Message
455 (Errno
: Integer) return C
.Strings
.chars_ptr
457 use type Interfaces
.C
.Strings
.chars_ptr
;
459 C_Msg
: C
.Strings
.chars_ptr
;
462 C_Msg
:= C_Strerror
(C
.int
(Errno
));
464 if C_Msg
= C
.Strings
.Null_Ptr
then
465 return Unknown_System_Error
;
470 end Socket_Error_Message
;
472 end GNAT
.Sockets
.Thin
;