------------------------------------------------------------------------------ -- -- -- 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-2003 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 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"); --------------- -- 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 : Fd_Set_Access := Readfds; WFS : 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 successfull and if 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 : Fd_Set_Access := New_Socket_Set (EFS); Buffer : Character; Length : C.int; Flag : C.int := MSG_PEEK + MSG_OOB; 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) 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 String is use GNAT.Sockets.Constants; begin case Errno is when EINTR => return "Interrupted system call"; when EBADF => return "Bad file number"; when EACCES => return "Permission denied"; when EFAULT => return "Bad address"; when EINVAL => return "Invalid argument"; when EMFILE => return "Too many open files"; when EWOULDBLOCK => return "Operation would block"; when EINPROGRESS => return "Operation now in progress. This error is " & "returned if any Windows Sockets API " & "function is called while a blocking " & "function is in progress"; when EALREADY => return "Operation already in progress"; when ENOTSOCK => return "Socket operation on nonsocket"; when EDESTADDRREQ => return "Destination address required"; when EMSGSIZE => return "Message too long"; when EPROTOTYPE => return "Protocol wrong type for socket"; when ENOPROTOOPT => return "Protocol not available"; when EPROTONOSUPPORT => return "Protocol not supported"; when ESOCKTNOSUPPORT => return "Socket type not supported"; when EOPNOTSUPP => return "Operation not supported on socket"; when EPFNOSUPPORT => return "Protocol family not supported"; when EAFNOSUPPORT => return "Address family not supported by protocol family"; when EADDRINUSE => return "Address already in use"; when EADDRNOTAVAIL => return "Cannot assign requested address"; when ENETDOWN => return "Network is down. This error may be " & "reported at any time if the Windows " & "Sockets implementation detects an " & "underlying failure"; when ENETUNREACH => return "Network is unreachable"; when ENETRESET => return "Network dropped connection on reset"; when ECONNABORTED => return "Software caused connection abort"; when ECONNRESET => return "Connection reset by peer"; when ENOBUFS => return "No buffer space available"; when EISCONN => return "Socket is already connected"; when ENOTCONN => return "Socket is not connected"; when ESHUTDOWN => return "Cannot send after socket shutdown"; when ETOOMANYREFS => return "Too many references: cannot splice"; when ETIMEDOUT => return "Connection timed out"; when ECONNREFUSED => return "Connection refused"; when ELOOP => return "Too many levels of symbolic links"; when ENAMETOOLONG => return "File name too long"; when EHOSTDOWN => return "Host is down"; when EHOSTUNREACH => return "No route to host"; when SYSNOTREADY => return "Returned by WSAStartup(), indicating that " & "the network subsystem is unusable"; when VERNOTSUPPORTED => return "Returned by WSAStartup(), indicating that " & "the Windows Sockets DLL cannot support this application"; when NOTINITIALISED => return "Winsock not initialized. This message is " & "returned by any function except WSAStartup(), " & "indicating that a successful WSAStartup() has " & "not yet been performed"; when EDISCON => return "Disconnect"; when HOST_NOT_FOUND => return "Host not found. This message indicates " & "that the key (name, address, and so on) was not found"; when TRY_AGAIN => return "Nonauthoritative host not found. This error may " & "suggest that the name service itself is not functioning"; when NO_RECOVERY => return "Nonrecoverable error. This error may suggest that the " & "name service itself is not functioning"; when NO_DATA => return "Valid name, no data record of requested type. " & "This error indicates that the key (name, address, " & "and so on) was not found."; when others => return "Unknown system error"; end case; end Socket_Error_Message; end GNAT.Sockets.Thin;