blob: 6bbdd0bf9583e5949f4f205d9b66220f676fb69c [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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-2022, 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;
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
Original_WFS : aliased Fd_Set;
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 /= null then
Original_WFS := Writefds.all;
-- 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 /= null 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 /= null
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;
------------------
-- C_Socketpair --
------------------
function C_Socketpair
(Domain : C.int;
Typ : C.int;
Protocol : C.int;
Fds : not null access Fd_Pair) return C.int is separate;
--------------
-- 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;