| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T . S O C K E T S . T H I N -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2014, AdaCore -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This package provides a target dependent thin interface to the sockets |
| -- layer for use by the GNAT.Sockets package (g-socket.ads). This package |
| -- should not be directly with'ed by an applications program. |
| |
| -- This version is for NT |
| |
| with Ada.Unchecked_Conversion; |
| with Interfaces.C.Strings; use Interfaces.C.Strings; |
| with System; use System; |
| with System.Storage_Elements; use System.Storage_Elements; |
| |
| package body GNAT.Sockets.Thin is |
| |
| use type C.unsigned; |
| use type C.int; |
| |
| WSAData_Dummy : array (1 .. 512) of C.int; |
| |
| WS_Version : constant := 16#0202#; |
| -- Winsock 2.2 |
| |
| Initialized : Boolean := False; |
| |
| function Standard_Connect |
| (S : C.int; |
| Name : System.Address; |
| Namelen : C.int) return C.int; |
| pragma Import (Stdcall, Standard_Connect, "connect"); |
| |
| function Standard_Select |
| (Nfds : C.int; |
| Readfds : access Fd_Set; |
| Writefds : access Fd_Set; |
| Exceptfds : access Fd_Set; |
| Timeout : Timeval_Access) return C.int; |
| pragma Import (Stdcall, Standard_Select, "select"); |
| |
| type Error_Type is |
| (N_EINTR, |
| N_EBADF, |
| N_EACCES, |
| N_EFAULT, |
| N_EINVAL, |
| N_EMFILE, |
| N_EWOULDBLOCK, |
| N_EINPROGRESS, |
| N_EALREADY, |
| N_ENOTSOCK, |
| N_EDESTADDRREQ, |
| N_EMSGSIZE, |
| N_EPROTOTYPE, |
| N_ENOPROTOOPT, |
| N_EPROTONOSUPPORT, |
| N_ESOCKTNOSUPPORT, |
| N_EOPNOTSUPP, |
| N_EPFNOSUPPORT, |
| N_EAFNOSUPPORT, |
| N_EADDRINUSE, |
| N_EADDRNOTAVAIL, |
| N_ENETDOWN, |
| N_ENETUNREACH, |
| N_ENETRESET, |
| N_ECONNABORTED, |
| N_ECONNRESET, |
| N_ENOBUFS, |
| N_EISCONN, |
| N_ENOTCONN, |
| N_ESHUTDOWN, |
| N_ETOOMANYREFS, |
| N_ETIMEDOUT, |
| N_ECONNREFUSED, |
| N_ELOOP, |
| N_ENAMETOOLONG, |
| N_EHOSTDOWN, |
| N_EHOSTUNREACH, |
| N_WSASYSNOTREADY, |
| N_WSAVERNOTSUPPORTED, |
| N_WSANOTINITIALISED, |
| N_WSAEDISCON, |
| N_HOST_NOT_FOUND, |
| N_TRY_AGAIN, |
| N_NO_RECOVERY, |
| N_NO_DATA, |
| N_OTHERS); |
| |
| Error_Messages : constant array (Error_Type) of chars_ptr := |
| (N_EINTR => |
| New_String ("Interrupted system call"), |
| N_EBADF => |
| New_String ("Bad file number"), |
| N_EACCES => |
| New_String ("Permission denied"), |
| N_EFAULT => |
| New_String ("Bad address"), |
| N_EINVAL => |
| New_String ("Invalid argument"), |
| N_EMFILE => |
| New_String ("Too many open files"), |
| N_EWOULDBLOCK => |
| New_String ("Operation would block"), |
| N_EINPROGRESS => |
| New_String ("Operation now in progress. This error is " |
| & "returned if any Windows Sockets API " |
| & "function is called while a blocking " |
| & "function is in progress"), |
| N_EALREADY => |
| New_String ("Operation already in progress"), |
| N_ENOTSOCK => |
| New_String ("Socket operation on nonsocket"), |
| N_EDESTADDRREQ => |
| New_String ("Destination address required"), |
| N_EMSGSIZE => |
| New_String ("Message too long"), |
| N_EPROTOTYPE => |
| New_String ("Protocol wrong type for socket"), |
| N_ENOPROTOOPT => |
| New_String ("Protocol not available"), |
| N_EPROTONOSUPPORT => |
| New_String ("Protocol not supported"), |
| N_ESOCKTNOSUPPORT => |
| New_String ("Socket type not supported"), |
| N_EOPNOTSUPP => |
| New_String ("Operation not supported on socket"), |
| N_EPFNOSUPPORT => |
| New_String ("Protocol family not supported"), |
| N_EAFNOSUPPORT => |
| New_String ("Address family not supported by protocol family"), |
| N_EADDRINUSE => |
| New_String ("Address already in use"), |
| N_EADDRNOTAVAIL => |
| New_String ("Cannot assign requested address"), |
| N_ENETDOWN => |
| New_String ("Network is down. This error may be " |
| & "reported at any time if the Windows " |
| & "Sockets implementation detects an " |
| & "underlying failure"), |
| N_ENETUNREACH => |
| New_String ("Network is unreachable"), |
| N_ENETRESET => |
| New_String ("Network dropped connection on reset"), |
| N_ECONNABORTED => |
| New_String ("Software caused connection abort"), |
| N_ECONNRESET => |
| New_String ("Connection reset by peer"), |
| N_ENOBUFS => |
| New_String ("No buffer space available"), |
| N_EISCONN => |
| New_String ("Socket is already connected"), |
| N_ENOTCONN => |
| New_String ("Socket is not connected"), |
| N_ESHUTDOWN => |
| New_String ("Cannot send after socket shutdown"), |
| N_ETOOMANYREFS => |
| New_String ("Too many references: cannot splice"), |
| N_ETIMEDOUT => |
| New_String ("Connection timed out"), |
| N_ECONNREFUSED => |
| New_String ("Connection refused"), |
| N_ELOOP => |
| New_String ("Too many levels of symbolic links"), |
| N_ENAMETOOLONG => |
| New_String ("File name too long"), |
| N_EHOSTDOWN => |
| New_String ("Host is down"), |
| N_EHOSTUNREACH => |
| New_String ("No route to host"), |
| N_WSASYSNOTREADY => |
| New_String ("Returned by WSAStartup(), indicating that " |
| & "the network subsystem is unusable"), |
| N_WSAVERNOTSUPPORTED => |
| New_String ("Returned by WSAStartup(), indicating that " |
| & "the Windows Sockets DLL cannot support " |
| & "this application"), |
| N_WSANOTINITIALISED => |
| New_String ("Winsock not initialized. This message is " |
| & "returned by any function except WSAStartup(), " |
| & "indicating that a successful WSAStartup() has " |
| & "not yet been performed"), |
| N_WSAEDISCON => |
| New_String ("Disconnected"), |
| N_HOST_NOT_FOUND => |
| New_String ("Host not found. This message indicates " |
| & "that the key (name, address, and so on) was not found"), |
| N_TRY_AGAIN => |
| New_String ("Nonauthoritative host not found. This error may " |
| & "suggest that the name service itself is not " |
| & "functioning"), |
| N_NO_RECOVERY => |
| New_String ("Nonrecoverable error. This error may suggest that the " |
| & "name service itself is not functioning"), |
| N_NO_DATA => |
| New_String ("Valid name, no data record of requested type. " |
| & "This error indicates that the key (name, address, " |
| & "and so on) was not found."), |
| N_OTHERS => |
| New_String ("Unknown system error")); |
| |
| --------------- |
| -- C_Connect -- |
| --------------- |
| |
| function C_Connect |
| (S : C.int; |
| Name : System.Address; |
| Namelen : C.int) return C.int |
| is |
| Res : C.int; |
| |
| begin |
| Res := Standard_Connect (S, Name, Namelen); |
| |
| if Res = -1 then |
| if Socket_Errno = SOSC.EWOULDBLOCK then |
| Set_Socket_Errno (SOSC.EINPROGRESS); |
| end if; |
| end if; |
| |
| return Res; |
| end C_Connect; |
| |
| ------------------ |
| -- Socket_Ioctl -- |
| ------------------ |
| |
| function Socket_Ioctl |
| (S : C.int; |
| Req : SOSC.IOCTL_Req_T; |
| Arg : access C.int) return C.int |
| is |
| begin |
| return C_Ioctl (S, Req, Arg); |
| end Socket_Ioctl; |
| |
| --------------- |
| -- C_Recvmsg -- |
| --------------- |
| |
| function C_Recvmsg |
| (S : C.int; |
| Msg : System.Address; |
| Flags : C.int) return System.CRTL.ssize_t |
| is |
| use type C.size_t; |
| |
| Fill : constant Boolean := |
| SOSC.MSG_WAITALL /= -1 |
| and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; |
| -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors |
| |
| Res : C.int; |
| Count : C.int := 0; |
| |
| MH : Msghdr; |
| for MH'Address use Msg; |
| |
| Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; |
| for Iovec'Address use MH.Msg_Iov; |
| pragma Import (Ada, Iovec); |
| |
| Iov_Index : Integer; |
| Current_Iovec : Vector_Element; |
| |
| function To_Access is new Ada.Unchecked_Conversion |
| (System.Address, Stream_Element_Reference); |
| pragma Warnings (Off, Stream_Element_Reference); |
| |
| Req : Request_Type (Name => N_Bytes_To_Read); |
| |
| begin |
| -- Windows does not provide an implementation of recvmsg(). The spec for |
| -- WSARecvMsg() is incompatible with the data types we define, and is |
| -- available starting with Windows Vista and Server 2008 only. So, |
| -- we use C_Recv instead. |
| |
| -- Check how much data are available |
| |
| Control_Socket (Socket_Type (S), Req); |
| |
| -- Fill the vectors |
| |
| Iov_Index := -1; |
| Current_Iovec := (Base => null, Length => 0); |
| |
| loop |
| if Current_Iovec.Length = 0 then |
| Iov_Index := Iov_Index + 1; |
| exit when Iov_Index > Integer (Iovec'Last); |
| Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); |
| end if; |
| |
| Res := |
| C_Recv |
| (S, |
| Current_Iovec.Base.all'Address, |
| C.int (Current_Iovec.Length), |
| Flags); |
| |
| if Res < 0 then |
| return System.CRTL.ssize_t (Res); |
| |
| elsif Res = 0 and then not Fill then |
| exit; |
| |
| else |
| pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); |
| |
| Count := Count + Res; |
| Current_Iovec.Length := |
| Current_Iovec.Length - Interfaces.C.size_t (Res); |
| Current_Iovec.Base := |
| To_Access (Current_Iovec.Base.all'Address |
| + Storage_Offset (Res)); |
| |
| -- If all the data that was initially available read, do not |
| -- attempt to receive more, since this might block, or merge data |
| -- from successive datagrams for a datagram-oriented socket. We |
| -- still try to receive more if we need to fill all vectors |
| -- (MSG_WAITALL flag is set). |
| |
| exit when Natural (Count) >= Req.Size |
| and then |
| |
| -- Either we are not in fill mode |
| |
| (not Fill |
| |
| -- Or else last vector filled |
| |
| or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last |
| and then Current_Iovec.Length = 0)); |
| end if; |
| end loop; |
| |
| return System.CRTL.ssize_t (Count); |
| end C_Recvmsg; |
| |
| -------------- |
| -- C_Select -- |
| -------------- |
| |
| function C_Select |
| (Nfds : C.int; |
| Readfds : access Fd_Set; |
| Writefds : access Fd_Set; |
| Exceptfds : access Fd_Set; |
| Timeout : Timeval_Access) return C.int |
| is |
| pragma Warnings (Off, Exceptfds); |
| |
| Original_WFS : aliased constant Fd_Set := Writefds.all; |
| |
| Res : C.int; |
| S : aliased C.int; |
| Last : aliased C.int; |
| |
| begin |
| -- Asynchronous connection failures are notified in the exception fd |
| -- set instead of the write fd set. To ensure POSIX compatibility, copy |
| -- write fd set into exception fd set. Once select() returns, check any |
| -- socket present in the exception fd set and peek at incoming |
| -- out-of-band data. If the test is not successful, and the socket is |
| -- present in the initial write fd set, then move the socket from the |
| -- exception fd set to the write fd set. |
| |
| if Writefds /= No_Fd_Set_Access then |
| |
| -- Add any socket present in write fd set into exception fd set |
| |
| declare |
| WFS : aliased Fd_Set := Writefds.all; |
| begin |
| Last := Nfds - 1; |
| loop |
| Get_Socket_From_Set |
| (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); |
| exit when S = -1; |
| Insert_Socket_In_Set (Exceptfds, S); |
| end loop; |
| end; |
| end if; |
| |
| Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); |
| |
| if Exceptfds /= No_Fd_Set_Access then |
| declare |
| EFSC : aliased Fd_Set := Exceptfds.all; |
| Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; |
| Buffer : Character; |
| Length : C.int; |
| Fromlen : aliased C.int; |
| |
| begin |
| Last := Nfds - 1; |
| loop |
| Get_Socket_From_Set |
| (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access); |
| |
| -- No more sockets in EFSC |
| |
| exit when S = -1; |
| |
| -- Check out-of-band data |
| |
| Length := |
| C_Recvfrom |
| (S, Buffer'Address, 1, Flag, |
| From => System.Null_Address, |
| Fromlen => Fromlen'Unchecked_Access); |
| -- Is Fromlen necessary if From is Null_Address??? |
| |
| -- If the signal is not an out-of-band data, then it |
| -- is a connection failure notification. |
| |
| if Length = -1 then |
| Remove_Socket_From_Set (Exceptfds, S); |
| |
| -- If S is present in the initial write fd set, move it from |
| -- exception fd set back to write fd set. Otherwise, ignore |
| -- this event since the user is not watching for it. |
| |
| if Writefds /= No_Fd_Set_Access |
| and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) |
| then |
| Insert_Socket_In_Set (Writefds, S); |
| end if; |
| end if; |
| end loop; |
| end; |
| end if; |
| return Res; |
| end C_Select; |
| |
| --------------- |
| -- C_Sendmsg -- |
| --------------- |
| |
| function C_Sendmsg |
| (S : C.int; |
| Msg : System.Address; |
| Flags : C.int) return System.CRTL.ssize_t |
| is |
| use type C.size_t; |
| |
| Res : C.int; |
| Count : C.int := 0; |
| |
| MH : Msghdr; |
| for MH'Address use Msg; |
| |
| Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; |
| for Iovec'Address use MH.Msg_Iov; |
| pragma Import (Ada, Iovec); |
| |
| begin |
| -- Windows does not provide an implementation of sendmsg(). The spec for |
| -- WSASendMsg() is incompatible with the data types we define, and is |
| -- available starting with Windows Vista and Server 2008 only. So |
| -- use C_Sendto instead. |
| |
| for J in Iovec'Range loop |
| Res := |
| C_Sendto |
| (S, |
| Iovec (J).Base.all'Address, |
| C.int (Iovec (J).Length), |
| Flags => Flags, |
| To => MH.Msg_Name, |
| Tolen => C.int (MH.Msg_Namelen)); |
| |
| if Res < 0 then |
| return System.CRTL.ssize_t (Res); |
| else |
| Count := Count + Res; |
| end if; |
| |
| -- Exit now if the buffer is not fully transmitted |
| |
| exit when Interfaces.C.size_t (Res) < Iovec (J).Length; |
| end loop; |
| |
| return System.CRTL.ssize_t (Count); |
| end C_Sendmsg; |
| |
| -------------- |
| -- Finalize -- |
| -------------- |
| |
| procedure Finalize is |
| begin |
| if Initialized then |
| WSACleanup; |
| Initialized := False; |
| end if; |
| end Finalize; |
| |
| ------------------------- |
| -- Host_Error_Messages -- |
| ------------------------- |
| |
| package body Host_Error_Messages is |
| |
| -- On Windows, socket and host errors share the same code space, and |
| -- error messages are provided by Socket_Error_Message, so the default |
| -- separate body for Host_Error_Messages is not used in this case. |
| |
| function Host_Error_Message (H_Errno : Integer) return String |
| renames Socket_Error_Message; |
| |
| end Host_Error_Messages; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| Return_Value : Interfaces.C.int; |
| begin |
| if not Initialized then |
| Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); |
| pragma Assert (Return_Value = 0); |
| Initialized := True; |
| end if; |
| end Initialize; |
| |
| -------------------- |
| -- Signalling_Fds -- |
| -------------------- |
| |
| package body Signalling_Fds is separate; |
| |
| -------------------------- |
| -- Socket_Error_Message -- |
| -------------------------- |
| |
| function Socket_Error_Message (Errno : Integer) return String is |
| use GNAT.Sockets.SOSC; |
| |
| Errm : C.Strings.chars_ptr; |
| |
| begin |
| case Errno is |
| when EINTR => Errm := Error_Messages (N_EINTR); |
| when EBADF => Errm := Error_Messages (N_EBADF); |
| when EACCES => Errm := Error_Messages (N_EACCES); |
| when EFAULT => Errm := Error_Messages (N_EFAULT); |
| when EINVAL => Errm := Error_Messages (N_EINVAL); |
| when EMFILE => Errm := Error_Messages (N_EMFILE); |
| when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); |
| when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); |
| when EALREADY => Errm := Error_Messages (N_EALREADY); |
| when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); |
| when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); |
| when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); |
| when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); |
| when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); |
| when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); |
| when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); |
| when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); |
| when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); |
| when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); |
| when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); |
| when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); |
| when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); |
| when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); |
| when ENETRESET => Errm := Error_Messages (N_ENETRESET); |
| when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); |
| when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); |
| when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); |
| when EISCONN => Errm := Error_Messages (N_EISCONN); |
| when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); |
| when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); |
| when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); |
| when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); |
| when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); |
| when ELOOP => Errm := Error_Messages (N_ELOOP); |
| when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); |
| when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); |
| when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); |
| |
| -- Windows-specific error codes |
| |
| when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); |
| when WSAVERNOTSUPPORTED => |
| Errm := Error_Messages (N_WSAVERNOTSUPPORTED); |
| when WSANOTINITIALISED => |
| Errm := Error_Messages (N_WSANOTINITIALISED); |
| when WSAEDISCON => |
| Errm := Error_Messages (N_WSAEDISCON); |
| |
| -- h_errno values |
| |
| when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); |
| when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); |
| when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); |
| when NO_DATA => Errm := Error_Messages (N_NO_DATA); |
| |
| when others => Errm := Error_Messages (N_OTHERS); |
| end case; |
| |
| return Value (Errm); |
| end Socket_Error_Message; |
| |
| end GNAT.Sockets.Thin; |
