g-socthi-mingw.adb [plain text]
with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with System; use System;
package body GNAT.Sockets.Thin is
use type C.unsigned;
WSAData_Dummy : array (1 .. 512) of C.int;
WS_Version : constant := 16#0101#;
Initialized : Boolean := False;
SYSNOTREADY : constant := 10091;
VERNOTSUPPORTED : constant := 10092;
NOTINITIALISED : constant := 10093;
EDISCON : constant := 10101;
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 : Fd_Set_Access;
Writefds : Fd_Set_Access;
Exceptfds : Fd_Set_Access;
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_SYSNOTREADY,
N_VERNOTSUPPORTED,
N_NOTINITIALISED,
N_EDISCON,
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_SYSNOTREADY =>
New_String ("Returned by WSAStartup(), indicating that "
& "the network subsystem is unusable"),
N_VERNOTSUPPORTED =>
New_String ("Returned by WSAStartup(), indicating that "
& "the Windows Sockets DLL cannot support "
& "this application"),
N_NOTINITIALISED =>
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_EDISCON =>
New_String ("Disconnect"),
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"));
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 = EWOULDBLOCK then
Set_Socket_Errno (EINPROGRESS);
end if;
end if;
return Res;
end C_Connect;
function C_Readv
(Socket : C.int;
Iov : System.Address;
Iovcnt : C.int)
return C.int
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
pragma Import (Ada, Iovec);
begin
for J in Iovec'Range loop
Res := C_Recv
(Socket,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
if Res < 0 then
return Res;
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Readv;
function C_Select
(Nfds : C.int;
Readfds : Fd_Set_Access;
Writefds : Fd_Set_Access;
Exceptfds : Fd_Set_Access;
Timeout : Timeval_Access)
return C.int
is
pragma Warnings (Off, Exceptfds);
RFS : constant Fd_Set_Access := Readfds;
WFS : constant Fd_Set_Access := Writefds;
WFSC : Fd_Set_Access := No_Fd_Set;
EFS : Fd_Set_Access := Exceptfds;
Res : C.int;
S : aliased C.int;
Last : aliased C.int;
begin
if WFS /= No_Fd_Set then
if EFS = No_Fd_Set then
EFS := New_Socket_Set (WFS);
else
WFSC := New_Socket_Set (WFS);
Last := Nfds - 1;
loop
Get_Socket_From_Set
(WFSC, S'Unchecked_Access, Last'Unchecked_Access);
exit when S = -1;
Insert_Socket_In_Set (EFS, S);
end loop;
Free_Socket_Set (WFSC);
end if;
WFSC := New_Socket_Set (WFS);
end if;
Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
if EFS /= No_Fd_Set then
declare
EFSC : constant Fd_Set_Access := New_Socket_Set (EFS);
Flag : constant C.int := MSG_PEEK + MSG_OOB;
Buffer : Character;
Length : C.int;
Fromlen : aliased C.int;
begin
Last := Nfds - 1;
loop
Get_Socket_From_Set
(EFSC, S'Unchecked_Access, Last'Unchecked_Access);
exit when S = -1;
Length := C_Recvfrom
(S, Buffer'Address, 1, Flag,
null, Fromlen'Unchecked_Access);
if Length = -1 then
Remove_Socket_From_Set (EFS, S);
if WFSC /= No_Fd_Set
and then (Is_Socket_In_Set (WFSC, S) /= 0)
then
Insert_Socket_In_Set (WFS, S);
end if;
end if;
end loop;
Free_Socket_Set (EFSC);
end;
if Exceptfds = No_Fd_Set then
Free_Socket_Set (EFS);
end if;
end if;
if WFSC /= No_Fd_Set then
Free_Socket_Set (WFSC);
end if;
return Res;
end C_Select;
function C_Writev
(Socket : C.int;
Iov : System.Address;
Iovcnt : C.int)
return C.int
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
pragma Import (Ada, Iovec);
begin
for J in Iovec'Range loop
Res := C_Send
(Socket,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
if Res < 0 then
return Res;
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Writev;
procedure Finalize is
begin
if Initialized then
WSACleanup;
Initialized := False;
end if;
end Finalize;
procedure Initialize (Process_Blocking_IO : Boolean := False) is
pragma Unreferenced (Process_Blocking_IO);
Return_Value : Interfaces.C.int;
begin
if not Initialized then
Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
pragma Assert (Interfaces.C."=" (Return_Value, 0));
Initialized := True;
end if;
end Initialize;
procedure Set_Address
(Sin : Sockaddr_In_Access;
Address : In_Addr)
is
begin
Sin.Sin_Addr := Address;
end Set_Address;
procedure Set_Family
(Sin : Sockaddr_In_Access;
Family : C.int)
is
begin
Sin.Sin_Family := C.unsigned_short (Family);
end Set_Family;
procedure Set_Length
(Sin : Sockaddr_In_Access;
Len : C.int)
is
pragma Unreferenced (Sin);
pragma Unreferenced (Len);
begin
null;
end Set_Length;
procedure Set_Port
(Sin : Sockaddr_In_Access;
Port : C.unsigned_short)
is
begin
Sin.Sin_Port := Port;
end Set_Port;
function Socket_Error_Message
(Errno : Integer)
return C.Strings.chars_ptr
is
use GNAT.Sockets.Constants;
begin
case Errno is
when EINTR => return Error_Messages (N_EINTR);
when EBADF => return Error_Messages (N_EBADF);
when EACCES => return Error_Messages (N_EACCES);
when EFAULT => return Error_Messages (N_EFAULT);
when EINVAL => return Error_Messages (N_EINVAL);
when EMFILE => return Error_Messages (N_EMFILE);
when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
when EALREADY => return Error_Messages (N_EALREADY);
when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
when ENETDOWN => return Error_Messages (N_ENETDOWN);
when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
when ENETRESET => return Error_Messages (N_ENETRESET);
when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
when ECONNRESET => return Error_Messages (N_ECONNRESET);
when ENOBUFS => return Error_Messages (N_ENOBUFS);
when EISCONN => return Error_Messages (N_EISCONN);
when ENOTCONN => return Error_Messages (N_ENOTCONN);
when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
when ELOOP => return Error_Messages (N_ELOOP);
when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY);
when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED);
when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED);
when EDISCON => return Error_Messages (N_EDISCON);
when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
when NO_DATA => return Error_Messages (N_NO_DATA);
when others => return Error_Messages (N_OTHERS);
end case;
end Socket_Error_Message;
end GNAT.Sockets.Thin;