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 is the version for OpenVMS
36 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
39 with Interfaces
.C
; use Interfaces
.C
;
41 package body GNAT
.Sockets
.Thin
is
43 type VMS_Msghdr
is new Msghdr
;
44 pragma Pack
(VMS_Msghdr
);
45 -- On VMS (unlike other platforms), struct msghdr is packed, so a specific
46 -- derived type is required.
48 Non_Blocking_Sockets
: aliased Fd_Set
;
49 -- When this package is initialized with Process_Blocking_IO set to True,
50 -- sockets are set in non-blocking mode to avoid blocking the whole process
51 -- when a thread wants to perform a blocking IO operation. But the user can
52 -- also set a socket in non-blocking mode by purpose. In order to make a
53 -- difference between these two situations, we track the origin of
54 -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in
55 -- Non_Blocking_Sockets, it has 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 to non-blocking
59 -- mode and we spend a period of time Quantum between two attempts on a
60 -- blocking operation.
62 Unknown_System_Error
: constant C
.Strings
.chars_ptr
:=
63 C
.Strings
.New_String
("Unknown system error");
65 function Syscall_Accept
67 Addr
: System
.Address
;
68 Addrlen
: not null access C
.int
) return C
.int
;
69 pragma Import
(C
, Syscall_Accept
, "accept");
71 function Syscall_Connect
73 Name
: System
.Address
;
74 Namelen
: C
.int
) return C
.int
;
75 pragma Import
(C
, Syscall_Connect
, "connect");
81 Flags
: C
.int
) return C
.int
;
82 pragma Import
(C
, Syscall_Recv
, "recv");
84 function Syscall_Recvfrom
89 From
: System
.Address
;
90 Fromlen
: not null access C
.int
) return C
.int
;
91 pragma Import
(C
, Syscall_Recvfrom
, "recvfrom");
93 function Syscall_Recvmsg
96 Flags
: C
.int
) return C
.int
;
97 pragma Import
(C
, Syscall_Recvmsg
, "recvmsg");
99 function Syscall_Sendmsg
101 Msg
: System
.Address
;
102 Flags
: C
.int
) return C
.int
;
103 pragma Import
(C
, Syscall_Sendmsg
, "sendmsg");
105 function Syscall_Sendto
107 Msg
: System
.Address
;
111 Tolen
: C
.int
) return C
.int
;
112 pragma Import
(C
, Syscall_Sendto
, "sendto");
114 function Syscall_Socket
115 (Domain
, Typ
, Protocol
: C
.int
) return C
.int
;
116 pragma Import
(C
, Syscall_Socket
, "socket");
118 function Non_Blocking_Socket
(S
: C
.int
) return Boolean;
119 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean);
127 Addr
: System
.Address
;
128 Addrlen
: not null access C
.int
) return C
.int
131 Val
: aliased C
.int
:= 1;
134 pragma Warnings
(Off
, Discard
);
138 R
:= Syscall_Accept
(S
, Addr
, Addrlen
);
139 exit when SOSC
.Thread_Blocking_IO
141 or else Non_Blocking_Socket
(S
)
142 or else Errno
/= SOSC
.EWOULDBLOCK
;
146 if not SOSC
.Thread_Blocking_IO
147 and then R
/= Failure
149 -- A socket inherits the properties of its server, especially
150 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
151 -- tracks sockets set in non-blocking mode by user.
153 Set_Non_Blocking_Socket
(R
, Non_Blocking_Socket
(S
));
154 Discard
:= C_Ioctl
(R
, SOSC
.FIONBIO
, Val
'Access);
166 Name
: System
.Address
;
167 Namelen
: C
.int
) return C
.int
172 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
174 if SOSC
.Thread_Blocking_IO
175 or else Res
/= Failure
176 or else Non_Blocking_Socket
(S
)
177 or else Errno
/= SOSC
.EINPROGRESS
183 WSet
: aliased Fd_Set
;
184 Now
: aliased Timeval
;
187 Reset_Socket_Set
(WSet
'Access);
189 Insert_Socket_In_Set
(WSet
'Access, S
);
196 Now
'Unchecked_Access);
200 if Res
= Failure
then
208 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
210 if Res
= Failure
and then Errno
= SOSC
.EISCONN
then
211 return Thin_Common
.Success
;
221 function Socket_Ioctl
224 Arg
: access C
.int
) return C
.int
227 if not SOSC
.Thread_Blocking_IO
and then Req
= SOSC
.FIONBIO
then
229 Set_Non_Blocking_Socket
(S
, True);
233 return C_Ioctl
(S
, Req
, Arg
);
242 Msg
: System
.Address
;
244 Flags
: C
.int
) return C
.int
250 Res
:= Syscall_Recv
(S
, Msg
, Len
, Flags
);
251 exit when SOSC
.Thread_Blocking_IO
252 or else Res
/= Failure
253 or else Non_Blocking_Socket
(S
)
254 or else Errno
/= SOSC
.EWOULDBLOCK
;
267 Msg
: System
.Address
;
270 From
: System
.Address
;
271 Fromlen
: not null access C
.int
) return C
.int
277 Res
:= Syscall_Recvfrom
(S
, Msg
, Len
, Flags
, From
, Fromlen
);
278 exit when SOSC
.Thread_Blocking_IO
279 or else Res
/= Failure
280 or else Non_Blocking_Socket
(S
)
281 or else Errno
/= SOSC
.EWOULDBLOCK
;
294 Msg
: System
.Address
;
295 Flags
: C
.int
) return System
.CRTL
.ssize_t
300 for GNAT_Msg
'Address use Msg
;
301 pragma Import
(Ada
, GNAT_Msg
);
303 VMS_Msg
: aliased VMS_Msghdr
:= VMS_Msghdr
(GNAT_Msg
);
307 Res
:= Syscall_Recvmsg
(S
, VMS_Msg
'Address, Flags
);
308 exit when SOSC
.Thread_Blocking_IO
309 or else Res
/= Failure
310 or else Non_Blocking_Socket
(S
)
311 or else Errno
/= SOSC
.EWOULDBLOCK
;
315 GNAT_Msg
:= Msghdr
(VMS_Msg
);
317 return System
.CRTL
.ssize_t
(Res
);
326 Msg
: System
.Address
;
327 Flags
: C
.int
) return System
.CRTL
.ssize_t
332 for GNAT_Msg
'Address use Msg
;
333 pragma Import
(Ada
, GNAT_Msg
);
335 VMS_Msg
: aliased VMS_Msghdr
:= VMS_Msghdr
(GNAT_Msg
);
339 Res
:= Syscall_Sendmsg
(S
, VMS_Msg
'Address, Flags
);
340 exit when SOSC
.Thread_Blocking_IO
341 or else Res
/= Failure
342 or else Non_Blocking_Socket
(S
)
343 or else Errno
/= SOSC
.EWOULDBLOCK
;
347 GNAT_Msg
:= Msghdr
(VMS_Msg
);
349 return System
.CRTL
.ssize_t
(Res
);
358 Msg
: System
.Address
;
362 Tolen
: C
.int
) return C
.int
368 Res
:= Syscall_Sendto
(S
, Msg
, Len
, Flags
, To
, Tolen
);
369 exit when SOSC
.Thread_Blocking_IO
370 or else Res
/= Failure
371 or else Non_Blocking_Socket
(S
)
372 or else Errno
/= SOSC
.EWOULDBLOCK
;
386 Protocol
: C
.int
) return C
.int
389 Val
: aliased C
.int
:= 1;
392 pragma Unreferenced
(Discard
);
395 R
:= Syscall_Socket
(Domain
, Typ
, Protocol
);
397 if not SOSC
.Thread_Blocking_IO
398 and then R
/= Failure
400 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
401 -- in non-blocking mode by user.
403 Discard
:= C_Ioctl
(R
, SOSC
.FIONBIO
, Val
'Access);
404 Set_Non_Blocking_Socket
(R
, False);
414 procedure Finalize
is
419 -------------------------
420 -- Host_Error_Messages --
421 -------------------------
423 package body Host_Error_Messages
is separate;
429 procedure Initialize
is
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 separate;
470 --------------------------
471 -- Socket_Error_Message --
472 --------------------------
474 function Socket_Error_Message
475 (Errno
: Integer) return C
.Strings
.chars_ptr
478 end GNAT
.Sockets
.Thin
;