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-2007, 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 -- Temporary version for Alpha/VMS
36 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
39 with Interfaces
.C
; use Interfaces
.C
;
41 package body GNAT
.Sockets
.Thin
is
43 Non_Blocking_Sockets
: constant Fd_Set_Access
:=
44 New_Socket_Set
(No_Socket_Set
);
45 -- When this package is initialized with Process_Blocking_IO set
46 -- to True, sockets are set in non-blocking mode to avoid blocking
47 -- the whole process when a thread wants to perform a blocking IO
48 -- operation. But the user can also set a socket in non-blocking
49 -- mode by purpose. In order to make a difference between these
50 -- two situations, we track the origin of non-blocking mode in
51 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
52 -- been set in non-blocking mode by the user.
54 Quantum
: constant Duration := 0.2;
55 -- When Constants.Thread_Blocking_IO is False, we set sockets in
56 -- non-blocking mode and we spend a period of time Quantum between
57 -- two attempts on a blocking operation.
59 Unknown_System_Error
: constant C
.Strings
.chars_ptr
:=
60 C
.Strings
.New_String
("Unknown system error");
62 function Syscall_Accept
64 Addr
: System
.Address
;
65 Addrlen
: not null access C
.int
) return C
.int
;
66 pragma Import
(C
, Syscall_Accept
, "accept");
68 function Syscall_Connect
70 Name
: System
.Address
;
71 Namelen
: C
.int
) return C
.int
;
72 pragma Import
(C
, Syscall_Connect
, "connect");
74 function Syscall_Ioctl
77 Arg
: Int_Access
) return C
.int
;
78 pragma Import
(C
, Syscall_Ioctl
, "ioctl");
84 Flags
: C
.int
) return C
.int
;
85 pragma Import
(C
, Syscall_Recv
, "recv");
87 function Syscall_Recvfrom
92 From
: Sockaddr_In_Access
;
93 Fromlen
: not null access C
.int
) return C
.int
;
94 pragma Import
(C
, Syscall_Recvfrom
, "recvfrom");
100 Flags
: C
.int
) return C
.int
;
101 pragma Import
(C
, Syscall_Send
, "send");
103 function Syscall_Sendto
105 Msg
: System
.Address
;
108 To
: Sockaddr_In_Access
;
109 Tolen
: C
.int
) return C
.int
;
110 pragma Import
(C
, Syscall_Sendto
, "sendto");
112 function Syscall_Socket
113 (Domain
, Typ
, Protocol
: C
.int
) return C
.int
;
114 pragma Import
(C
, Syscall_Socket
, "socket");
116 function Non_Blocking_Socket
(S
: C
.int
) return Boolean;
117 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean);
125 Addr
: System
.Address
;
126 Addrlen
: not null access C
.int
) return C
.int
129 Val
: aliased C
.int
:= 1;
132 pragma Warnings
(Off
, Discard
);
136 R
:= Syscall_Accept
(S
, Addr
, Addrlen
);
137 exit when Constants
.Thread_Blocking_IO
139 or else Non_Blocking_Socket
(S
)
140 or else Errno
/= Constants
.EWOULDBLOCK
;
144 if not Constants
.Thread_Blocking_IO
145 and then R
/= Failure
147 -- A socket inherits the properties ot its server especially
148 -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
149 -- tracks sockets set in non-blocking mode by user.
151 Set_Non_Blocking_Socket
(R
, Non_Blocking_Socket
(S
));
152 Discard
:= Syscall_Ioctl
(R
, Constants
.FIONBIO
, Val
'Unchecked_Access);
164 Name
: System
.Address
;
165 Namelen
: C
.int
) return C
.int
170 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
172 if Constants
.Thread_Blocking_IO
173 or else Res
/= Failure
174 or else Non_Blocking_Socket
(S
)
175 or else Errno
/= Constants
.EINPROGRESS
181 WSet
: Fd_Set_Access
;
182 Now
: aliased Timeval
;
185 WSet
:= New_Socket_Set
(No_Socket_Set
);
187 Insert_Socket_In_Set
(WSet
, S
);
194 Now
'Unchecked_Access);
198 if Res
= Failure
then
199 Free_Socket_Set
(WSet
);
206 Free_Socket_Set
(WSet
);
209 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
212 and then Errno
= Constants
.EISCONN
227 Arg
: Int_Access
) return C
.int
230 if not Constants
.Thread_Blocking_IO
231 and then Req
= Constants
.FIONBIO
234 Set_Non_Blocking_Socket
(S
, True);
238 return Syscall_Ioctl
(S
, Req
, Arg
);
247 Msg
: System
.Address
;
249 Flags
: C
.int
) return C
.int
255 Res
:= Syscall_Recv
(S
, Msg
, Len
, Flags
);
256 exit when Constants
.Thread_Blocking_IO
257 or else Res
/= Failure
258 or else Non_Blocking_Socket
(S
)
259 or else Errno
/= Constants
.EWOULDBLOCK
;
272 Msg
: System
.Address
;
275 From
: Sockaddr_In_Access
;
276 Fromlen
: not null access C
.int
) return C
.int
282 Res
:= Syscall_Recvfrom
(S
, Msg
, Len
, Flags
, From
, Fromlen
);
283 exit when Constants
.Thread_Blocking_IO
284 or else Res
/= Failure
285 or else Non_Blocking_Socket
(S
)
286 or else Errno
/= Constants
.EWOULDBLOCK
;
299 Msg
: System
.Address
;
301 Flags
: C
.int
) return C
.int
307 Res
:= Syscall_Send
(S
, Msg
, Len
, Flags
);
308 exit when Constants
.Thread_Blocking_IO
309 or else Res
/= Failure
310 or else Non_Blocking_Socket
(S
)
311 or else Errno
/= Constants
.EWOULDBLOCK
;
324 Msg
: System
.Address
;
327 To
: Sockaddr_In_Access
;
328 Tolen
: C
.int
) return C
.int
334 Res
:= Syscall_Sendto
(S
, Msg
, Len
, Flags
, To
, Tolen
);
335 exit when Constants
.Thread_Blocking_IO
336 or else Res
/= Failure
337 or else Non_Blocking_Socket
(S
)
338 or else Errno
/= Constants
.EWOULDBLOCK
;
352 Protocol
: C
.int
) return C
.int
355 Val
: aliased C
.int
:= 1;
358 pragma Unreferenced
(Discard
);
361 R
:= Syscall_Socket
(Domain
, Typ
, Protocol
);
363 if not Constants
.Thread_Blocking_IO
364 and then R
/= Failure
366 -- Do not use C_Ioctl as this subprogram tracks sockets set
367 -- in non-blocking mode by user.
369 Discard
:= Syscall_Ioctl
(R
, Constants
.FIONBIO
, Val
'Unchecked_Access);
370 Set_Non_Blocking_Socket
(R
, False);
380 procedure Finalize
is
385 -------------------------
386 -- Host_Error_Messages --
387 -------------------------
389 package body Host_Error_Messages
is separate;
395 procedure Initialize
is
400 -------------------------
401 -- Non_Blocking_Socket --
402 -------------------------
404 function Non_Blocking_Socket
(S
: C
.int
) return Boolean is
408 R
:= (Is_Socket_In_Set
(Non_Blocking_Sockets
, S
) /= 0);
411 end Non_Blocking_Socket
;
417 procedure Set_Address
(Sin
: Sockaddr_In_Access
; Address
: In_Addr
) is
419 Sin
.Sin_Addr
:= Address
;
426 procedure Set_Family
(Sin
: Sockaddr_In_Access
; Family
: C
.int
) is
428 Sin
.Sin_Family
:= C
.unsigned_short
(Family
);
435 procedure Set_Length
(Sin
: Sockaddr_In_Access
; Len
: C
.int
) is
436 pragma Unreferenced
(Sin
);
437 pragma Unreferenced
(Len
);
442 -----------------------------
443 -- Set_Non_Blocking_Socket --
444 -----------------------------
446 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean) is
451 Insert_Socket_In_Set
(Non_Blocking_Sockets
, S
);
453 Remove_Socket_From_Set
(Non_Blocking_Sockets
, S
);
457 end Set_Non_Blocking_Socket
;
463 procedure Set_Port
(Sin
: Sockaddr_In_Access
; Port
: C
.unsigned_short
) is
465 Sin
.Sin_Port
:= Port
;
472 package body Signalling_Fds
is separate;
474 --------------------------
475 -- Socket_Error_Message --
476 --------------------------
478 function Socket_Error_Message
479 (Errno
: Integer) return C
.Strings
.chars_ptr
481 use type Interfaces
.C
.Strings
.chars_ptr
;
483 C_Msg
: C
.Strings
.chars_ptr
;
486 C_Msg
:= C_Strerror
(C
.int
(Errno
));
488 if C_Msg
= C
.Strings
.Null_Ptr
then
489 return Unknown_System_Error
;
493 end Socket_Error_Message
;
501 Iov
: System
.Address
;
502 Iovcnt
: C
.int
) return C
.int
507 Iovec
: array (0 .. Iovcnt
- 1) of Vector_Element
;
508 for Iovec
'Address use Iov
;
509 pragma Import
(Ada
, Iovec
);
512 for J
in Iovec
'Range loop
515 Iovec
(J
).Base
.all'Address,
516 Interfaces
.C
.int
(Iovec
(J
).Length
),
522 Count
:= Count
+ Res
;
534 Iov
: System
.Address
;
535 Iovcnt
: C
.int
) return C
.int
540 Iovec
: array (0 .. Iovcnt
- 1) of Vector_Element
;
541 for Iovec
'Address use Iov
;
542 pragma Import
(Ada
, Iovec
);
545 for J
in Iovec
'Range loop
548 Iovec
(J
).Base
.all'Address,
549 Interfaces
.C
.int
(Iovec
(J
).Length
),
550 Constants
.MSG_Forced_Flags
);
555 Count
:= Count
+ Res
;
561 end GNAT
.Sockets
.Thin
;