File : src/aws-net-sets.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                            Copyright (C) 2004                            --
--                                ACT-Europe                                 --
--                                                                          --
--  Authors: Dmitriy Anisimkov - Pascal Obry                                --
--                                                                          --
--  This library is free software; you can redistribute it and/or modify    --
--  it under the terms of the GNU General Public License as published by    --
--  the Free Software Foundation; either version 2 of the License, or (at   --
--  your option) any later version.                                         --
--                                                                          --
--  This library is distributed in the hope that it will be useful, but     --
--  WITHOUT 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       --
--  along with this library; if not, write to the Free Software Foundation, --
--  Inc., 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.                                     --
------------------------------------------------------------------------------

--  $Id: aws-net-sets.adb,v 1.7 2004/03/03 08:08:10 anisimko Exp $

with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with AWS.Net.Sets.Thin;

package body AWS.Net.Sets is

   type Poll_Set_Type is array (Positive range <>) of Thin.Pollfd;
   pragma Pack (Poll_Set_Type);

   procedure Free is
     new Ada.Unchecked_Deallocation (Poll_Set_Type, Poll_Set_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Socket_Array, Socket_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Socket_Type'Class, Socket_Access);
      --  We could not use AWS.Net.Free because Socket_Set_Type did not
      --  allocate internal socket data.

   function To_State (Event : in Thin.Events_Type) return Socket_State;
   --  Convert Event to the proper Socket_State

   procedure Add_Private
     (Set    : in out Socket_Set_Type;
      Socket : in     Socket_Access;
      Mode   : in     Waiting_Mode);
   --  Add Socket into Set

   procedure Next_Private (Set : in out Socket_Set_Type);
   --  Looking for next active sockets beginning from current

   ---------
   -- Add --
   ---------

   procedure Add
     (Set    : in out Socket_Set_Type;
      Socket : in     Socket_Type'Class;
      Mode   : in     Waiting_Mode) is
   begin
      Add_Private (Set, new Socket_Type'Class'(Socket), Mode);
      Set.Set (Set.Last).Allocated := True;
   end Add;

   procedure Add
     (Set    : in out Socket_Set_Type;
      Socket : in     Socket_Access;
      Mode   : in     Waiting_Mode) is
   begin
      Add_Private (Set, Socket, Mode);
      Set.Set (Set.Last).Allocated := False;
   end Add;

   -----------------
   -- Add_Private --
   -----------------

   procedure Add_Private
     (Set    : in out Socket_Set_Type;
      Socket : in     Socket_Access;
      Mode   : in     Waiting_Mode)
   is
      use type Thin.Events_Type;
   begin
      if Set.Poll = null then
         if Set.Last /= 0 then
            raise Constraint_Error;
         end if;

         if Set.Set /= null then
            raise Constraint_Error;
         end if;

         --  Allocate only few elements in array first, because this package
         --  often would be used for wait just one socket.

         Set.Poll := new Poll_Set_Type (1 .. 4);
         Set.Set  := new Socket_Array (Set.Poll'Range);

      elsif Set.Last >= Set.Poll'Length then
         declare
            Prev_Set  : Socket_Array_Access := Set.Set;
            Prev_Poll : Poll_Set_Access     := Set.Poll;
            Increment : Positive;

         begin
            if Set.Last < 256 then
               Increment := Set.Last;
            else
               Increment := 256;
            end if;

            Set.Poll := new Poll_Set_Type (1 .. Set.Last + Increment);
            Set.Set  := new Socket_Array (Set.Poll'Range);

            Set.Poll (Prev_Poll'Range) := Prev_Poll.all;
            Set.Set  (Prev_Set'Range)  := Prev_Set.all;

            Free (Prev_Set);
            Free (Prev_Poll);
         end;
      end if;

      Set.Last := Set.Last + 1;

      Set.Set (Set.Last).Socket := Socket;
      Set.Poll (Set.Last).FD := Thin.FD_Type (Get_FD (Socket.all));

      case Mode is
         when Input  =>
            Set.Poll (Set.Last).Events := Thin.Pollin;
         when Output =>
            Set.Poll (Set.Last).Events := Thin.Pollout;
         when Both   =>
            Set.Poll (Set.Last).Events := Thin.Pollin + Thin.Pollout;
      end case;
   end Add_Private;

   -----------
   -- Count --
   -----------

   function Count (Set : Socket_Set_Type) return Natural is
   begin
      return Set.Last;
   end Count;

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

   procedure Finalize (Set : in out Socket_Set_Type) is
   begin
      Free (Set.Set);
      Free (Set.Poll);
   end Finalize;

   ----------------
   -- Get_Socket --
   ----------------

   function Get_Socket (Set : in Socket_Set_Type) return Socket_Type'Class is
   begin
      if Set.Current > Set.Last then
         raise Constraint_Error;
      else
         return Set.Set (Set.Current).Socket.all;
      end if;
   end Get_Socket;

   ----------------------
   -- Get_Socket_State --
   ----------------------

   function Get_Socket_State (Set : in Socket_Set_Type) return Socket_State is
   begin
      if Set.Current > Set.Last then
         return None;
      else
         return To_State (Set.Poll (Set.Current).REvents);
      end if;
   end Get_Socket_State;

   ----------
   -- Next --
   ----------

   procedure Next (Set : in out Socket_Set_Type) is
      use type Thin.Events_Type;
   begin
      loop
         Set.Current := Set.Current + 1;

         exit when Set.Current > Set.Last
           or else Set.Poll (Set.Current).REvents /= 0;
      end loop;
   end Next;

   ------------------
   -- Next_Private --
   ------------------

   procedure Next_Private (Set : in out Socket_Set_Type) is
      use type Thin.Events_Type;
   begin
      while Set.Current <= Set.Last
        and then Set.Poll (Set.Current).REvents = 0
      loop
         Set.Current := Set.Current + 1;
      end loop;
   end Next_Private;

   -------------------
   -- Remove_Socket --
   -------------------

   procedure Remove_Socket (Set : in out Socket_Set_Type) is
   begin
      if Set.Current > Set.Last then
         raise Constraint_Error;
      end if;

      if Set.Set (Set.Current).Allocated then
         Sets.Free (Set.Set (Set.Current).Socket);
      end if;

      Set.Set (Set.Current)  := Set.Set (Set.Last);
      Set.Poll (Set.Current) := Set.Poll (Set.Last);

      Set.Last := Set.Last - 1;

      Next_Private (Set);
   end Remove_Socket;

   -----------
   -- Reset --
   -----------

   procedure Reset (Set : in out Socket_Set_Type) is
   begin
      for K in 1 .. Set.Last loop
         if Set.Set (K).Allocated then
            Sets.Free (Set.Set (K).Socket);
         end if;
      end loop;

      Set.Last := 0;
   end Reset;

   --------------
   -- To_State --
   --------------

   function To_State (Event : in Thin.Events_Type) return Socket_State is
      use type Thin.Events_Type;
   begin
      if (Event and (Thin.Pollerr
                    or Thin.Pollhup
                    or Thin.Pollnval
                    or Thin.Pollin
                    or Thin.Pollpri
                    or Thin.Pollout)) = 0
      then
         return None;
      end if;

      if (Event and (Thin.Pollerr or Thin.Pollhup or Thin.Pollnval)) /= 0 then
         return Error;
      end if;

      if (Event and (Thin.Pollin or Thin.Pollpri)) /= 0 then
         if (Event and Thin.Pollout) /= 0 then
            return Both;
         else
            return Input;
         end if;
      else
         return Output;
      end if;
   end To_State;

   ----------
   -- Wait --
   ----------

   procedure Wait (Set : in out Socket_Set_Type; Timeout : in  Duration) is
      use type Thin.Timeout_Type;

      Result       : Integer;
      Poll_Timeout : Thin.Timeout_Type;
   begin
      if Timeout >= Duration (Thin.Timeout_Type'Last / 1000) then
         Poll_Timeout := Thin.Timeout_Type'Last;
      else
         Poll_Timeout := Thin.Timeout_Type (Timeout * 1000);
      end if;

      Result := Integer
        (Thin.Poll
           (FDS     => Set.Poll (1)'Address,
            Nfds    => Thin.Length_Type (Set.Last),
            Timeout => Poll_Timeout));

      if Result < 0 then
         Ada.Exceptions.Raise_Exception
           (Socket_Error'Identity, "Poll error code" & Integer'Image (Errno));

      elsif Result > 0 then
         Set.Current := 1;
         Next_Private (Set);
      end if;
   end Wait;

end AWS.Net.Sets;