path: root/gcc/ada/g-socthi.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                    G N A T . S O C K E T S . T H I N                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.5 $
--                                                                          --
--              Copyright (C) 2001 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.OS_Lib; use GNAT.OS_Lib;

with Interfaces.C; use Interfaces.C;

package body GNAT.Sockets.Thin is

   --  When this package is initialized with Process_Blocking_IO set
   --  to True, sockets are set in non-blocking mode to avoid blocking
   --  the whole process when a thread wants to perform a blocking IO
   --  operation. But the user can set a socket in non-blocking mode
   --  by purpose. We track the socket in such a mode by redefining
   --  C_Ioctl. In blocking IO operations, we exit normally when the
   --  non-blocking flag is set by user, we poll and try later when
   --  this flag is set automatically by this package.

   type Socket_Info is record
      Non_Blocking : Boolean := False;
   end record;

   Table : array (C.int range 0 .. 31) of Socket_Info;
   --  Get info on blocking flag. This array is limited to 32 sockets
   --  because the select operation allows socket set of less then 32
   --  sockets.

   Quantum : constant Duration := 0.2;
   --  comment needed ???

   Thread_Blocking_IO : Boolean := True;

   function Syscall_Accept
     (S       : C.int;
      Addr    : System.Address;
      Addrlen : access C.int)
      return    C.int;
   pragma Import (C, Syscall_Accept, "accept");

   function Syscall_Connect
     (S       : C.int;
      Name    : System.Address;
      Namelen : C.int)
      return    C.int;
   pragma Import (C, Syscall_Connect, "connect");

   function Syscall_Ioctl
     (S    : C.int;
      Req  : C.int;
      Arg  : Int_Access)
      return C.int;
   pragma Import (C, Syscall_Ioctl, "ioctl");

   function Syscall_Recv
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int)
      return  C.int;
   pragma Import (C, Syscall_Recv, "recv");

   function Syscall_Recvfrom
     (S       : C.int;
      Msg     : System.Address;
      Len     : C.int;
      Flags   : C.int;
      From    : Sockaddr_In_Access;
      Fromlen : access C.int)
      return    C.int;
   pragma Import (C, Syscall_Recvfrom, "recvfrom");

   function Syscall_Send
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int)
      return  C.int;
   pragma Import (C, Syscall_Send, "send");

   function Syscall_Sendto
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int;
      To    : Sockaddr_In_Access;
      Tolen : C.int)
      return  C.int;
   pragma Import (C, Syscall_Sendto, "sendto");

   function Syscall_Socket
     (Domain, Typ, Protocol : C.int)
      return C.int;
   pragma Import (C, Syscall_Socket, "socket");

   procedure Set_Non_Blocking (S : C.int);

   --------------
   -- C_Accept --
   --------------

   function C_Accept
     (S       : C.int;
      Addr    : System.Address;
      Addrlen : access C.int)
      return    C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Accept (S, Addr, Addrlen);
         exit when Thread_Blocking_IO
           or else Res /= Failure
           or else Table (S).Non_Blocking
           or else Errno /= Constants.EWOULDBLOCK;
         delay Quantum;
      end loop;

      if not Thread_Blocking_IO
        and then Res /= Failure
      then
         --  A socket inherits the properties ot its server especially
         --  the FNDELAY flag.

         Table (Res).Non_Blocking := Table (S).Non_Blocking;
         Set_Non_Blocking (Res);
      end if;

      return Res;
   end C_Accept;

   ---------------
   -- C_Connect --
   ---------------

   function C_Connect
     (S       : C.int;
      Name    : System.Address;
      Namelen : C.int)
      return    C.int
   is
      Res : C.int;

   begin
      Res := Syscall_Connect (S, Name, Namelen);

      if Thread_Blocking_IO
        or else Res /= Failure
        or else Table (S).Non_Blocking
        or else Errno /= Constants.EINPROGRESS
      then
         return Res;
      end if;

      declare
         Set : aliased Fd_Set;
         Now : aliased Timeval;

      begin
         loop
            Set := 2 ** Natural (S);
            Now := Immediat;
            Res := C_Select
              (S + 1,
               null, Set'Unchecked_Access,
               null, Now'Unchecked_Access);

            exit when Res > 0;

            if Res = Failure then
               return Res;
            end if;

            delay Quantum;
         end loop;
      end;

      Res := Syscall_Connect (S, Name, Namelen);

      if Res = Failure
        and then Errno = Constants.EISCONN
      then
         return Thin.Success;
      else
         return Res;
      end if;
   end C_Connect;

   -------------
   -- C_Ioctl --
   -------------

   function C_Ioctl
     (S    : C.int;
      Req  : C.int;
      Arg  : Int_Access)
      return C.int
   is
   begin
      if not Thread_Blocking_IO
        and then Req = Constants.FIONBIO
      then
         Table (S).Non_Blocking := (Arg.all /= 0);
      end if;

      return Syscall_Ioctl (S, Req, Arg);
   end C_Ioctl;

   ------------
   -- C_Recv --
   ------------

   function C_Recv
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int)
      return  C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Recv (S, Msg, Len, Flags);
         exit when Thread_Blocking_IO
           or else Res /= Failure
           or else Table (S).Non_Blocking
           or else Errno /= Constants.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Recv;

   ----------------
   -- C_Recvfrom --
   ----------------

   function C_Recvfrom
     (S       : C.int;
      Msg     : System.Address;
      Len     : C.int;
      Flags   : C.int;
      From    : Sockaddr_In_Access;
      Fromlen : access C.int)
      return    C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
         exit when Thread_Blocking_IO
           or else Res /= Failure
           or else Table (S).Non_Blocking
           or else Errno /= Constants.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Recvfrom;

   ------------
   -- C_Send --
   ------------

   function C_Send
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int)
      return  C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Send (S, Msg, Len, Flags);
         exit when Thread_Blocking_IO
           or else Res /= Failure
           or else Table (S).Non_Blocking
           or else Errno /= Constants.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Send;

   --------------
   -- C_Sendto --
   --------------

   function C_Sendto
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int;
      To    : Sockaddr_In_Access;
      Tolen : C.int)
      return  C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
         exit when Thread_Blocking_IO
           or else Res /= Failure
           or else Table (S).Non_Blocking
           or else Errno /= Constants.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Sendto;

   --------------
   -- C_Socket --
   --------------

   function C_Socket
     (Domain   : C.int;
      Typ      : C.int;
      Protocol : C.int)
      return     C.int
   is
      Res : C.int;

   begin
      Res := Syscall_Socket (Domain, Typ, Protocol);

      if not Thread_Blocking_IO
        and then Res /= Failure
      then
         Set_Non_Blocking (Res);
      end if;

      return Res;
   end C_Socket;

   -----------
   -- Clear --
   -----------

   procedure Clear
     (Item   : in out Fd_Set;
      Socket : in C.int)
   is
      Mask : constant Fd_Set := 2 ** Natural (Socket);

   begin
      if (Item and Mask) /= 0 then
         Item := Item xor Mask;
      end if;
   end Clear;

   -----------
   -- Empty --
   -----------

   procedure Empty  (Item : in out Fd_Set) is
   begin
      Item := 0;
   end Empty;

   --------------
   -- Finalize --
   --------------

   procedure Finalize is
   begin
      null;
   end Finalize;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Process_Blocking_IO : Boolean) is
   begin
      Thread_Blocking_IO := not Process_Blocking_IO;
   end Initialize;

   --------------
   -- Is_Empty --
   --------------

   function Is_Empty (Item : Fd_Set) return Boolean is
   begin
      return Item = 0;
   end Is_Empty;

   ------------
   -- Is_Set --
   ------------

   function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
   begin
      return (Item and 2 ** Natural (Socket)) /= 0;
   end Is_Set;

   ---------
   -- Max --
   ---------

   function Max (Item : Fd_Set) return C.int
   is
      L : C.int  := -1;
      C : Fd_Set := Item;

   begin
      while C /= 0 loop
         L := L + 1;
         C := C / 2;
      end loop;
      return L;
   end Max;

   ---------
   -- Set --
   ---------

   procedure Set (Item : in out Fd_Set; Socket : in C.int) is
   begin
      Item := Item or 2 ** Natural (Socket);
   end Set;

   ----------------------
   -- Set_Non_Blocking --
   ----------------------

   procedure Set_Non_Blocking (S : C.int) is
      Res : C.int;
      Val : aliased C.int := 1;

   begin

      --  Do not use C_Fcntl because this subprogram tracks the
      --  sockets set by user in non-blocking mode.

      Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
   end Set_Non_Blocking;

   --------------------------
   -- Socket_Error_Message --
   --------------------------

   function Socket_Error_Message (Errno : Integer) return String is
      use type Interfaces.C.Strings.chars_ptr;

      C_Msg : C.Strings.chars_ptr;

   begin
      C_Msg := C_Strerror (C.int (Errno));

      if C_Msg = C.Strings.Null_Ptr then
         return "Unknown system error";

      else
         return C.Strings.Value (C_Msg);
      end if;
   end Socket_Error_Message;

end GNAT.Sockets.Thin;