Subversion Repositories scarts

------------------------------------------------------------------------------
--                                                                          --
--                         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-2005, 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 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,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, 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_Inet_Addr --
   -----------------
 
   function C_Inet_Addr
     (Cp : C.Strings.chars_ptr) return C.int
   is
      use type C.unsigned_long;
 
      function Internal_Inet_Addr
        (Cp : C.Strings.chars_ptr) return C.unsigned_long;
      pragma Import (Stdcall, Internal_Inet_Addr, "inet_addr");
 
      Res : C.unsigned_long;
   begin
      Res := Internal_Inet_Addr (Cp);
 
      if Res = C.unsigned_long'Last then
         --  This value is returned in case of error
         return -1;
      else
         return C.int (Internal_Inet_Addr (Cp));
      end if;
   end C_Inet_Addr;
 
   --------------
   -- 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
   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;