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-2010, 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 NT
40 with Ada.Streams; use Ada.Streams;
41 with Ada.Unchecked_Conversion;
42 with Interfaces.C.Strings; use Interfaces.C.Strings;
43 with System; use System;
44 with System.Storage_Elements; use System.Storage_Elements;
46 package body GNAT.Sockets.Thin is
51 WSAData_Dummy : array (1 .. 512) of C.int;
53 WS_Version : constant := 16#0202#;
56 Initialized : Boolean := False;
58 function Standard_Connect
60 Name : System.Address;
61 Namelen : C.int) return C.int;
62 pragma Import (Stdcall, Standard_Connect, "connect");
64 function Standard_Select
66 Readfds : access Fd_Set;
67 Writefds : access Fd_Set;
68 Exceptfds : access Fd_Set;
69 Timeout : Timeval_Access) return C.int;
70 pragma Import (Stdcall, Standard_Select, "select");
111 N_WSAVERNOTSUPPORTED,
120 Error_Messages : constant array (Error_Type) of chars_ptr :=
122 New_String ("Interrupted system call"),
124 New_String ("Bad file number"),
126 New_String ("Permission denied"),
128 New_String ("Bad address"),
130 New_String ("Invalid argument"),
132 New_String ("Too many open files"),
134 New_String ("Operation would block"),
136 New_String ("Operation now in progress. This error is "
137 & "returned if any Windows Sockets API "
138 & "function is called while a blocking "
139 & "function is in progress"),
141 New_String ("Operation already in progress"),
143 New_String ("Socket operation on nonsocket"),
145 New_String ("Destination address required"),
147 New_String ("Message too long"),
149 New_String ("Protocol wrong type for socket"),
151 New_String ("Protocol not available"),
153 New_String ("Protocol not supported"),
155 New_String ("Socket type not supported"),
157 New_String ("Operation not supported on socket"),
159 New_String ("Protocol family not supported"),
161 New_String ("Address family not supported by protocol family"),
163 New_String ("Address already in use"),
165 New_String ("Cannot assign requested address"),
167 New_String ("Network is down. This error may be "
168 & "reported at any time if the Windows "
169 & "Sockets implementation detects an "
170 & "underlying failure"),
172 New_String ("Network is unreachable"),
174 New_String ("Network dropped connection on reset"),
176 New_String ("Software caused connection abort"),
178 New_String ("Connection reset by peer"),
180 New_String ("No buffer space available"),
182 New_String ("Socket is already connected"),
184 New_String ("Socket is not connected"),
186 New_String ("Cannot send after socket shutdown"),
188 New_String ("Too many references: cannot splice"),
190 New_String ("Connection timed out"),
192 New_String ("Connection refused"),
194 New_String ("Too many levels of symbolic links"),
196 New_String ("File name too long"),
198 New_String ("Host is down"),
200 New_String ("No route to host"),
202 New_String ("Returned by WSAStartup(), indicating that "
203 & "the network subsystem is unusable"),
204 N_WSAVERNOTSUPPORTED =>
205 New_String ("Returned by WSAStartup(), indicating that "
206 & "the Windows Sockets DLL cannot support "
207 & "this application"),
208 N_WSANOTINITIALISED =>
209 New_String ("Winsock not initialized. This message is "
210 & "returned by any function except WSAStartup(), "
211 & "indicating that a successful WSAStartup() has "
212 & "not yet been performed"),
214 New_String ("Disconnected"),
216 New_String ("Host not found. This message indicates "
217 & "that the key (name, address, and so on) was not found"),
219 New_String ("Nonauthoritative host not found. This error may "
220 & "suggest that the name service itself is not "
223 New_String ("Nonrecoverable error. This error may suggest that the "
224 & "name service itself is not functioning"),
226 New_String ("Valid name, no data record of requested type. "
227 & "This error indicates that the key (name, address, "
228 & "and so on) was not found."),
230 New_String ("Unknown system error"));
238 Name : System.Address;
239 Namelen : C.int) return C.int
244 Res := Standard_Connect (S, Name, Namelen);
247 if Socket_Errno = SOSC.EWOULDBLOCK then
248 Set_Socket_Errno (SOSC.EINPROGRESS);
259 function Socket_Ioctl
262 Arg : access C.int) return C.int
265 return C_Ioctl (S, Req, Arg);
274 Msg : System.Address;
275 Flags : C.int) return System.CRTL.ssize_t
279 Fill : constant Boolean :=
280 SOSC.MSG_WAITALL /= -1
281 and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
282 -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
288 for MH'Address use Msg;
290 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
291 for Iovec'Address use MH.Msg_Iov;
292 pragma Import (Ada, Iovec);
295 Current_Iovec : Vector_Element;
297 function To_Access is new Ada.Unchecked_Conversion
298 (System.Address, Stream_Element_Reference);
299 pragma Warnings (Off, Stream_Element_Reference);
301 Req : Request_Type (Name => N_Bytes_To_Read);
304 -- Windows does not provide an implementation of recvmsg(). The spec for
305 -- WSARecvMsg() is incompatible with the data types we define, and is
306 -- available starting with Windows Vista and Server 2008 only. So,
307 -- we use C_Recv instead.
309 -- Check how much data are available
311 Control_Socket (Socket_Type (S), Req);
316 Current_Iovec := (Base => null, Length => 0);
319 if Current_Iovec.Length = 0 then
320 Iov_Index := Iov_Index + 1;
321 exit when Iov_Index > Integer (Iovec'Last);
322 Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
328 Current_Iovec.Base.all'Address,
329 C.int (Current_Iovec.Length),
333 return System.CRTL.ssize_t (Res);
335 elsif Res = 0 and then not Fill then
339 pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length);
341 Count := Count + Res;
342 Current_Iovec.Length :=
343 Current_Iovec.Length - Stream_Element_Count (Res);
344 Current_Iovec.Base :=
345 To_Access (Current_Iovec.Base.all'Address
346 + Storage_Offset (Res));
348 -- If all the data that was initially available read, do not
349 -- attempt to receive more, since this might block, or merge data
350 -- from successive datagrams for a datagram-oriented socket. We
351 -- still try to receive more if we need to fill all vectors
352 -- (MSG_WAITALL flag is set).
354 exit when Natural (Count) >= Req.Size
357 -- Either we are not in fill mode
361 -- Or else last vector filled
363 or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
364 and then Current_Iovec.Length = 0));
368 return System.CRTL.ssize_t (Count);
377 Readfds : access Fd_Set;
378 Writefds : access Fd_Set;
379 Exceptfds : access Fd_Set;
380 Timeout : Timeval_Access) return C.int
382 pragma Warnings (Off, Exceptfds);
384 Original_WFS : aliased constant Fd_Set := Writefds.all;
388 Last : aliased C.int;
391 -- Asynchronous connection failures are notified in the exception fd
392 -- set instead of the write fd set. To ensure POSIX compatibility, copy
393 -- write fd set into exception fd set. Once select() returns, check any
394 -- socket present in the exception fd set and peek at incoming
395 -- out-of-band data. If the test is not successful, and the socket is
396 -- present in the initial write fd set, then move the socket from the
397 -- exception fd set to the write fd set.
399 if Writefds /= No_Fd_Set_Access then
401 -- Add any socket present in write fd set into exception fd set
404 WFS : aliased Fd_Set := Writefds.all;
409 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
411 Insert_Socket_In_Set (Exceptfds, S);
416 Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
418 if Exceptfds /= No_Fd_Set_Access then
420 EFSC : aliased Fd_Set := Exceptfds.all;
421 Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
424 Fromlen : aliased C.int;
430 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
432 -- No more sockets in EFSC
436 -- Check out-of-band data
440 (S, Buffer'Address, 1, Flag,
441 From => System.Null_Address,
442 Fromlen => Fromlen'Unchecked_Access);
443 -- Is Fromlen necessary if From is Null_Address???
445 -- If the signal is not an out-of-band data, then it
446 -- is a connection failure notification.
449 Remove_Socket_From_Set (Exceptfds, S);
451 -- If S is present in the initial write fd set, move it from
452 -- exception fd set back to write fd set. Otherwise, ignore
453 -- this event since the user is not watching for it.
455 if Writefds /= No_Fd_Set_Access
456 and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
458 Insert_Socket_In_Set (Writefds, S);
473 Msg : System.Address;
474 Flags : C.int) return System.CRTL.ssize_t
482 for MH'Address use Msg;
484 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
485 for Iovec'Address use MH.Msg_Iov;
486 pragma Import (Ada, Iovec);
489 -- Windows does not provide an implementation of sendmsg(). The spec for
490 -- WSASendMsg() is incompatible with the data types we define, and is
491 -- available starting with Windows Vista and Server 2008 only. So
492 -- use C_Sendto instead.
494 for J in Iovec'Range loop
498 Iovec (J).Base.all'Address,
499 C.int (Iovec (J).Length),
502 Tolen => C.int (MH.Msg_Namelen));
505 return System.CRTL.ssize_t (Res);
507 Count := Count + Res;
510 -- Exit now if the buffer is not fully transmitted
512 exit when Stream_Element_Count (Res) < Iovec (J).Length;
515 return System.CRTL.ssize_t (Count);
522 procedure Finalize is
526 Initialized := False;
530 -------------------------
531 -- Host_Error_Messages --
532 -------------------------
534 package body Host_Error_Messages is
536 -- On Windows, socket and host errors share the same code space, and
537 -- error messages are provided by Socket_Error_Message, so the default
538 -- separate body for Host_Error_Messages is not used in this case.
540 function Host_Error_Message
541 (H_Errno : Integer) return C.Strings.chars_ptr
542 renames Socket_Error_Message;
544 end Host_Error_Messages;
550 procedure Initialize is
551 Return_Value : Interfaces.C.int;
553 if not Initialized then
554 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
555 pragma Assert (Return_Value = 0);
564 package body Signalling_Fds is separate;
566 --------------------------
567 -- Socket_Error_Message --
568 --------------------------
570 function Socket_Error_Message
571 (Errno : Integer) return C.Strings.chars_ptr
573 use GNAT.Sockets.SOSC;
577 when EINTR => return Error_Messages (N_EINTR);
578 when EBADF => return Error_Messages (N_EBADF);
579 when EACCES => return Error_Messages (N_EACCES);
580 when EFAULT => return Error_Messages (N_EFAULT);
581 when EINVAL => return Error_Messages (N_EINVAL);
582 when EMFILE => return Error_Messages (N_EMFILE);
583 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
584 when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
585 when EALREADY => return Error_Messages (N_EALREADY);
586 when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
587 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
588 when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
589 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
590 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
591 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
592 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
593 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
594 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
595 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
596 when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
597 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
598 when ENETDOWN => return Error_Messages (N_ENETDOWN);
599 when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
600 when ENETRESET => return Error_Messages (N_ENETRESET);
601 when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
602 when ECONNRESET => return Error_Messages (N_ECONNRESET);
603 when ENOBUFS => return Error_Messages (N_ENOBUFS);
604 when EISCONN => return Error_Messages (N_EISCONN);
605 when ENOTCONN => return Error_Messages (N_ENOTCONN);
606 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
607 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
608 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
609 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
610 when ELOOP => return Error_Messages (N_ELOOP);
611 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
612 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
613 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
615 -- Windows-specific error codes
617 when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY);
618 when WSAVERNOTSUPPORTED =>
619 return Error_Messages (N_WSAVERNOTSUPPORTED);
620 when WSANOTINITIALISED =>
621 return Error_Messages (N_WSANOTINITIALISED);
622 when WSAEDISCON => return Error_Messages (N_WSAEDISCON);
626 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
627 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
628 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
629 when NO_DATA => return Error_Messages (N_NO_DATA);
631 when others => return Error_Messages (N_OTHERS);
633 end Socket_Error_Message;
635 end GNAT.Sockets.Thin;