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-2017, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This package provides a target dependent thin interface to the sockets
33 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
34 -- should not be directly with'ed by an applications program.
36 -- This version is for NT
38 with Ada
.Unchecked_Conversion
;
39 with Interfaces
.C
.Strings
; use Interfaces
.C
.Strings
;
40 with System
; use System
;
41 with System
.Storage_Elements
; use System
.Storage_Elements
;
43 package body GNAT
.Sockets
.Thin
is
47 WSAData_Dummy
: array (1 .. 512) of C
.int
;
49 WS_Version
: constant := 16#
0202#
;
52 Initialized
: Boolean := False;
54 function Standard_Connect
56 Name
: System
.Address
;
57 Namelen
: C
.int
) return C
.int
;
58 pragma Import
(Stdcall
, Standard_Connect
, "connect");
60 function Standard_Select
62 Readfds
: access Fd_Set
;
63 Writefds
: access Fd_Set
;
64 Exceptfds
: access Fd_Set
;
65 Timeout
: Timeval_Access
) return C
.int
;
66 pragma Import
(Stdcall
, Standard_Select
, "select");
107 N_WSAVERNOTSUPPORTED
,
116 Error_Messages
: constant array (Error_Type
) of chars_ptr
:=
118 New_String
("Interrupted system call"),
120 New_String
("Bad file number"),
122 New_String
("Permission denied"),
124 New_String
("Bad address"),
126 New_String
("Invalid argument"),
128 New_String
("Too many open files"),
130 New_String
("Operation would block"),
132 New_String
("Operation now in progress. This error is "
133 & "returned if any Windows Sockets API "
134 & "function is called while a blocking "
135 & "function is in progress"),
137 New_String
("Operation already in progress"),
139 New_String
("Socket operation on nonsocket"),
141 New_String
("Destination address required"),
143 New_String
("Message too long"),
145 New_String
("Protocol wrong type for socket"),
147 New_String
("Protocol not available"),
149 New_String
("Protocol not supported"),
151 New_String
("Socket type not supported"),
153 New_String
("Operation not supported on socket"),
155 New_String
("Protocol family not supported"),
157 New_String
("Address family not supported by protocol family"),
159 New_String
("Address already in use"),
161 New_String
("Cannot assign requested address"),
163 New_String
("Network is down. This error may be "
164 & "reported at any time if the Windows "
165 & "Sockets implementation detects an "
166 & "underlying failure"),
168 New_String
("Network is unreachable"),
170 New_String
("Network dropped connection on reset"),
172 New_String
("Software caused connection abort"),
174 New_String
("Connection reset by peer"),
176 New_String
("No buffer space available"),
178 New_String
("Socket is already connected"),
180 New_String
("Socket is not connected"),
182 New_String
("Cannot send after socket shutdown"),
184 New_String
("Too many references: cannot splice"),
186 New_String
("Connection timed out"),
188 New_String
("Connection refused"),
190 New_String
("Too many levels of symbolic links"),
192 New_String
("File name too long"),
194 New_String
("Host is down"),
196 New_String
("No route to host"),
198 New_String
("Returned by WSAStartup(), indicating that "
199 & "the network subsystem is unusable"),
200 N_WSAVERNOTSUPPORTED
=>
201 New_String
("Returned by WSAStartup(), indicating that "
202 & "the Windows Sockets DLL cannot support "
203 & "this application"),
204 N_WSANOTINITIALISED
=>
205 New_String
("Winsock not initialized. This message is "
206 & "returned by any function except WSAStartup(), "
207 & "indicating that a successful WSAStartup() has "
208 & "not yet been performed"),
210 New_String
("Disconnected"),
212 New_String
("Host not found. This message indicates "
213 & "that the key (name, address, and so on) was not found"),
215 New_String
("Nonauthoritative host not found. This error may "
216 & "suggest that the name service itself is not "
219 New_String
("Nonrecoverable error. This error may suggest that the "
220 & "name service itself is not functioning"),
222 New_String
("Valid name, no data record of requested type. "
223 & "This error indicates that the key (name, address, "
224 & "and so on) was not found."),
226 New_String
("Unknown system error"));
234 Name
: System
.Address
;
235 Namelen
: C
.int
) return C
.int
240 Res
:= Standard_Connect
(S
, Name
, Namelen
);
243 if Socket_Errno
= SOSC
.EWOULDBLOCK
then
244 Set_Socket_Errno
(SOSC
.EINPROGRESS
);
255 function Socket_Ioctl
257 Req
: SOSC
.IOCTL_Req_T
;
258 Arg
: access C
.int
) return C
.int
261 return C_Ioctl
(S
, Req
, Arg
);
270 Msg
: System
.Address
;
271 Flags
: C
.int
) return System
.CRTL
.ssize_t
275 Fill
: constant Boolean :=
276 SOSC
.MSG_WAITALL
/= -1
277 and then (C
.unsigned
(Flags
) and SOSC
.MSG_WAITALL
) /= 0;
278 -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
284 for MH
'Address use Msg
;
286 Iovec
: array (0 .. MH
.Msg_Iovlen
- 1) of Vector_Element
;
287 for Iovec
'Address use MH
.Msg_Iov
;
288 pragma Import
(Ada
, Iovec
);
291 Current_Iovec
: Vector_Element
;
293 function To_Access
is new Ada
.Unchecked_Conversion
294 (System
.Address
, Stream_Element_Reference
);
295 pragma Warnings
(Off
, Stream_Element_Reference
);
297 Req
: Request_Type
(Name
=> N_Bytes_To_Read
);
300 -- Windows does not provide an implementation of recvmsg(). The spec for
301 -- WSARecvMsg() is incompatible with the data types we define, and is
302 -- available starting with Windows Vista and Server 2008 only. So,
303 -- we use C_Recv instead.
305 -- Check how much data are available
307 Control_Socket
(Socket_Type
(S
), Req
);
312 Current_Iovec
:= (Base
=> null, Length
=> 0);
315 if Current_Iovec
.Length
= 0 then
316 Iov_Index
:= Iov_Index
+ 1;
317 exit when Iov_Index
> Integer (Iovec
'Last);
318 Current_Iovec
:= Iovec
(SOSC
.Msg_Iovlen_T
(Iov_Index
));
324 Current_Iovec
.Base
.all'Address,
325 C
.int
(Current_Iovec
.Length
),
329 return System
.CRTL
.ssize_t
(Res
);
331 elsif Res
= 0 and then not Fill
then
335 pragma Assert
(Interfaces
.C
.size_t
(Res
) <= Current_Iovec
.Length
);
337 Count
:= Count
+ Res
;
338 Current_Iovec
.Length
:=
339 Current_Iovec
.Length
- Interfaces
.C
.size_t
(Res
);
340 Current_Iovec
.Base
:=
341 To_Access
(Current_Iovec
.Base
.all'Address
342 + Storage_Offset
(Res
));
344 -- If all the data that was initially available read, do not
345 -- attempt to receive more, since this might block, or merge data
346 -- from successive datagrams for a datagram-oriented socket. We
347 -- still try to receive more if we need to fill all vectors
348 -- (MSG_WAITALL flag is set).
350 exit when Natural (Count
) >= Req
.Size
353 -- Either we are not in fill mode
357 -- Or else last vector filled
359 or else (Interfaces
.C
.size_t
(Iov_Index
) = Iovec
'Last
360 and then Current_Iovec
.Length
= 0));
364 return System
.CRTL
.ssize_t
(Count
);
373 Readfds
: access Fd_Set
;
374 Writefds
: access Fd_Set
;
375 Exceptfds
: access Fd_Set
;
376 Timeout
: Timeval_Access
) return C
.int
378 pragma Warnings
(Off
, Exceptfds
);
380 Original_WFS
: aliased constant Fd_Set
:= Writefds
.all;
384 Last
: aliased C
.int
;
387 -- Asynchronous connection failures are notified in the exception fd
388 -- set instead of the write fd set. To ensure POSIX compatibility, copy
389 -- write fd set into exception fd set. Once select() returns, check any
390 -- socket present in the exception fd set and peek at incoming
391 -- out-of-band data. If the test is not successful, and the socket is
392 -- present in the initial write fd set, then move the socket from the
393 -- exception fd set to the write fd set.
395 if Writefds
/= No_Fd_Set_Access
then
397 -- Add any socket present in write fd set into exception fd set
400 WFS
: aliased Fd_Set
:= Writefds
.all;
405 (WFS
'Access, S
'Unchecked_Access, Last
'Unchecked_Access);
407 Insert_Socket_In_Set
(Exceptfds
, S
);
412 Res
:= Standard_Select
(Nfds
, Readfds
, Writefds
, Exceptfds
, Timeout
);
414 if Exceptfds
/= No_Fd_Set_Access
then
416 EFSC
: aliased Fd_Set
:= Exceptfds
.all;
417 Flag
: constant C
.int
:= SOSC
.MSG_PEEK
+ SOSC
.MSG_OOB
;
420 Fromlen
: aliased C
.int
;
426 (EFSC
'Access, S
'Unchecked_Access, Last
'Unchecked_Access);
428 -- No more sockets in EFSC
432 -- Check out-of-band data
436 (S
, Buffer
'Address, 1, Flag
,
437 From
=> System
.Null_Address
,
438 Fromlen
=> Fromlen
'Unchecked_Access);
439 -- Is Fromlen necessary if From is Null_Address???
441 -- If the signal is not an out-of-band data, then it
442 -- is a connection failure notification.
445 Remove_Socket_From_Set
(Exceptfds
, S
);
447 -- If S is present in the initial write fd set, move it from
448 -- exception fd set back to write fd set. Otherwise, ignore
449 -- this event since the user is not watching for it.
451 if Writefds
/= No_Fd_Set_Access
452 and then (Is_Socket_In_Set
(Original_WFS
'Access, S
) /= 0)
454 Insert_Socket_In_Set
(Writefds
, S
);
469 Msg
: System
.Address
;
470 Flags
: C
.int
) return System
.CRTL
.ssize_t
478 for MH
'Address use Msg
;
480 Iovec
: array (0 .. MH
.Msg_Iovlen
- 1) of Vector_Element
;
481 for Iovec
'Address use MH
.Msg_Iov
;
482 pragma Import
(Ada
, Iovec
);
485 -- Windows does not provide an implementation of sendmsg(). The spec for
486 -- WSASendMsg() is incompatible with the data types we define, and is
487 -- available starting with Windows Vista and Server 2008 only. So
488 -- use C_Sendto instead.
490 for J
in Iovec
'Range loop
494 Iovec
(J
).Base
.all'Address,
495 C
.int
(Iovec
(J
).Length
),
498 Tolen
=> C
.int
(MH
.Msg_Namelen
));
501 return System
.CRTL
.ssize_t
(Res
);
503 Count
:= Count
+ Res
;
506 -- Exit now if the buffer is not fully transmitted
508 exit when Interfaces
.C
.size_t
(Res
) < Iovec
(J
).Length
;
511 return System
.CRTL
.ssize_t
(Count
);
518 procedure Finalize
is
522 Initialized
:= False;
526 -------------------------
527 -- Host_Error_Messages --
528 -------------------------
530 package body Host_Error_Messages
is
532 -- On Windows, socket and host errors share the same code space, and
533 -- error messages are provided by Socket_Error_Message, so the default
534 -- separate body for Host_Error_Messages is not used in this case.
536 function Host_Error_Message
(H_Errno
: Integer) return String
537 renames Socket_Error_Message
;
539 end Host_Error_Messages
;
545 procedure Initialize
is
546 Return_Value
: Interfaces
.C
.int
;
548 if not Initialized
then
549 Return_Value
:= WSAStartup
(WS_Version
, WSAData_Dummy
'Address);
550 pragma Assert
(Return_Value
= 0);
559 package body Signalling_Fds
is separate;
561 --------------------------
562 -- Socket_Error_Message --
563 --------------------------
565 function Socket_Error_Message
(Errno
: Integer) return String is
566 use GNAT
.Sockets
.SOSC
;
568 Errm
: C
.Strings
.chars_ptr
;
572 when EINTR
=> Errm
:= Error_Messages
(N_EINTR
);
573 when EBADF
=> Errm
:= Error_Messages
(N_EBADF
);
574 when EACCES
=> Errm
:= Error_Messages
(N_EACCES
);
575 when EFAULT
=> Errm
:= Error_Messages
(N_EFAULT
);
576 when EINVAL
=> Errm
:= Error_Messages
(N_EINVAL
);
577 when EMFILE
=> Errm
:= Error_Messages
(N_EMFILE
);
578 when EWOULDBLOCK
=> Errm
:= Error_Messages
(N_EWOULDBLOCK
);
579 when EINPROGRESS
=> Errm
:= Error_Messages
(N_EINPROGRESS
);
580 when EALREADY
=> Errm
:= Error_Messages
(N_EALREADY
);
581 when ENOTSOCK
=> Errm
:= Error_Messages
(N_ENOTSOCK
);
582 when EDESTADDRREQ
=> Errm
:= Error_Messages
(N_EDESTADDRREQ
);
583 when EMSGSIZE
=> Errm
:= Error_Messages
(N_EMSGSIZE
);
584 when EPROTOTYPE
=> Errm
:= Error_Messages
(N_EPROTOTYPE
);
585 when ENOPROTOOPT
=> Errm
:= Error_Messages
(N_ENOPROTOOPT
);
586 when EPROTONOSUPPORT
=> Errm
:= Error_Messages
(N_EPROTONOSUPPORT
);
587 when ESOCKTNOSUPPORT
=> Errm
:= Error_Messages
(N_ESOCKTNOSUPPORT
);
588 when EOPNOTSUPP
=> Errm
:= Error_Messages
(N_EOPNOTSUPP
);
589 when EPFNOSUPPORT
=> Errm
:= Error_Messages
(N_EPFNOSUPPORT
);
590 when EAFNOSUPPORT
=> Errm
:= Error_Messages
(N_EAFNOSUPPORT
);
591 when EADDRINUSE
=> Errm
:= Error_Messages
(N_EADDRINUSE
);
592 when EADDRNOTAVAIL
=> Errm
:= Error_Messages
(N_EADDRNOTAVAIL
);
593 when ENETDOWN
=> Errm
:= Error_Messages
(N_ENETDOWN
);
594 when ENETUNREACH
=> Errm
:= Error_Messages
(N_ENETUNREACH
);
595 when ENETRESET
=> Errm
:= Error_Messages
(N_ENETRESET
);
596 when ECONNABORTED
=> Errm
:= Error_Messages
(N_ECONNABORTED
);
597 when ECONNRESET
=> Errm
:= Error_Messages
(N_ECONNRESET
);
598 when ENOBUFS
=> Errm
:= Error_Messages
(N_ENOBUFS
);
599 when EISCONN
=> Errm
:= Error_Messages
(N_EISCONN
);
600 when ENOTCONN
=> Errm
:= Error_Messages
(N_ENOTCONN
);
601 when ESHUTDOWN
=> Errm
:= Error_Messages
(N_ESHUTDOWN
);
602 when ETOOMANYREFS
=> Errm
:= Error_Messages
(N_ETOOMANYREFS
);
603 when ETIMEDOUT
=> Errm
:= Error_Messages
(N_ETIMEDOUT
);
604 when ECONNREFUSED
=> Errm
:= Error_Messages
(N_ECONNREFUSED
);
605 when ELOOP
=> Errm
:= Error_Messages
(N_ELOOP
);
606 when ENAMETOOLONG
=> Errm
:= Error_Messages
(N_ENAMETOOLONG
);
607 when EHOSTDOWN
=> Errm
:= Error_Messages
(N_EHOSTDOWN
);
608 when EHOSTUNREACH
=> Errm
:= Error_Messages
(N_EHOSTUNREACH
);
610 -- Windows-specific error codes
612 when WSASYSNOTREADY
=> Errm
:= Error_Messages
(N_WSASYSNOTREADY
);
613 when WSAVERNOTSUPPORTED
=>
614 Errm
:= Error_Messages
(N_WSAVERNOTSUPPORTED
);
615 when WSANOTINITIALISED
=>
616 Errm
:= Error_Messages
(N_WSANOTINITIALISED
);
617 when WSAEDISCON
=> Errm
:= Error_Messages
(N_WSAEDISCON
);
621 when HOST_NOT_FOUND
=> Errm
:= Error_Messages
(N_HOST_NOT_FOUND
);
622 when TRY_AGAIN
=> Errm
:= Error_Messages
(N_TRY_AGAIN
);
623 when NO_RECOVERY
=> Errm
:= Error_Messages
(N_NO_RECOVERY
);
624 when NO_DATA
=> Errm
:= Error_Messages
(N_NO_DATA
);
625 when others => Errm
:= Error_Messages
(N_OTHERS
);
629 end Socket_Error_Message
;
631 end GNAT
.Sockets
.Thin
;