------------------------------------------------------------------------------ -- -- -- 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-2004 Ada Core Technologies, Inc. -- -- -- -- 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 2, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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 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")); --------------- -- 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 = EWOULDBLOCK then Set_Socket_Errno (EINPROGRESS); end if; end if; return Res; end C_Connect; ------------- -- C_Readv -- ------------- 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; -------------- -- C_Select -- -------------- 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 -- Asynchronous connection failures are notified in the -- exception fd set instead of the write fd set. To ensure -- POSIX compatitibility, 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 WFS /= No_Fd_Set then -- Add any socket present in write fd set into exception fd set 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; -- Keep a copy of write fd set 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); -- No more sockets in EFSC exit when S = -1; -- Check out-of-band data Length := C_Recvfrom (S, Buffer'Address, 1, Flag, null, Fromlen'Unchecked_Access); -- 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 (EFS, 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 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; -- Free any copy of write fd set if WFSC /= No_Fd_Set then Free_Socket_Set (WFSC); end if; return Res; end C_Select; -------------- -- C_Writev -- -------------- 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; -------------- -- Finalize -- -------------- procedure Finalize is begin if Initialized then WSACleanup; Initialized := False; end if; end Finalize; ---------------- -- Initialize -- ---------------- 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; ----------------- -- Set_Address -- ----------------- procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is begin Sin.Sin_Addr := Address; end Set_Address; ---------------- -- Set_Family -- ---------------- procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is begin Sin.Sin_Family := C.unsigned_short (Family); end Set_Family; ---------------- -- Set_Length -- ---------------- procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is pragma Unreferenced (Sin); pragma Unreferenced (Len); begin null; end Set_Length; -------------- -- Set_Port -- -------------- procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is begin Sin.Sin_Port := Port; end Set_Port; -------------------------- -- Socket_Error_Message -- -------------------------- 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;