-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014, 2015, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;

package body MAT.Frames is

   use type MAT.Types.Target_Addr;

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   --  ------------------------------
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table is
      Length  : Natural;
   begin
      if Max_Level > 0 and Max_Level < Frame.Depth then
         Length := Max_Level;
      else
         Length := Frame.Depth;
      end if;
      declare
         Current : Frame_Type := Frame;
         Pos     : Natural    := Length;
         Pc      : Frame_Table (1 .. Length);
      begin
         while Current /= null and Pos /= 0 loop
            Pc (Pos) := Current.Pc;
            Pos := Pos - 1;
            Current := Current.Parent;
         end loop;
         return Pc;
      end;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Pc;
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame '(Parent => null, Depth => 0, Pc => 0, others => <>);
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Frame.Children := F.Next;
         Destroy (F);
      end loop;
      Free (Frame);
   end Destroy;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F.Children;
      Parent        : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
   begin
      while Pos <= Pc'Last loop
         Current_Depth := Current_Depth + 1;
         Child := new Frame '(Parent      => Parent,
                              Next        => Child,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Pc          => Pc (Pos));
         Pos := Pos + 1;
         Parent.Children := Child;
         Parent := Child;
         Child := null;
      end loop;
      Result := Parent;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Parent  : Frame_Type := Frame;
      Current : Frame_Type := Frame.Children;
      Pos     : Positive  := Pc'First;
      Addr    : MAT.Types.Target_Addr;
   begin
      if Pc'Length = 0 then
         Result := Frame;
         Frame.Used := Frame.Used + 1;
         return;
      end if;
      if Current = null then
         Add_Frame (Frame, Pc, Result);
         return;
      end if;
      Addr := Pc (Pos);
      loop
         if Addr = Current.Pc then
            Current.Used := Current.Used + 1;
            Pos  := Pos + 1;
            if Pos > Pc'Last then
               Result := Current;
               return;
            end if;
            if Current.Children = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Parent := Current;
            Current := Current.Children;
            Addr := Pc (Pos);

         elsif Current.Next = null then
            Add_Frame (Parent, Pc (Pos .. Pc'Last), Result);
            return;
         else
            Current := Current.Next;
         end if;
      end loop;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Pc = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
--     function Find (Frame : in Frame_Type;
--                    Pc    : in Frame_Table) return Frame_Type is
--        Child : Frame_Type := Frame;
--        Pos   : Positive  := Pc'First;
--     begin
--        while Pos <= Pc'Last loop
--           Child := Find (Child, Pc (Pos));
--           Pos  := Pos + 1;
--           --  All the PC of the child frame must match.
--           while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
--              if Child.Calls (Lpos) /= Pc (Pos) then
--                 raise Not_Found;
--              end if;
--              Lpos := Lpos + 1;
--              Pos  := Pos + 1;
--           end loop;
--        end loop;
--        return Child;
--     end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
--     --  ------------------------------
--     procedure Find (Frame   : in Frame_Type;
--                     Pc      : in Frame_Table;
--                     Result  : out Frame_Type;
--                     Last_Pc : out Natural) is
--        Current : Frame_Type := Frame;
--        Pos     : Positive  := Pc'First;
--        Lpos    : Positive;
--     begin
--        Main_Search :
--        while Pos <= Pc'Last loop
--           declare
--              Addr  : constant MAT.Types.Target_Addr := Pc (Pos);
--              Child : Frame_Type  := Current.Children;
--           begin
--              --  Find the child which has the corresponding PC.
--              loop
--                 exit Main_Search when Child = null;
--                 exit when Child.Pc = Addr;
--                 Child := Child.Next;
--              end loop;
--
--              Current := Child;
--              Pos  := Pos + 1;
--              Lpos := 2;
--              --  All the PC of the child frame must match.
--              while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
--                 exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
--                 Lpos := Lpos + 1;
--                 Pos  := Pos + 1;
--              end loop;
--           end;
--        end loop Main_Search;
--        Result := Current;
--        if Pos > Pc'Last then
--           Last_Pc := 0;
--        else
--           Last_Pc := Pos;
--        end if;
--     end Find;

   --  ------------------------------
   --  Check whether the frame contains a call to the function described by the address range.
   --  ------------------------------
   function In_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean is
      Current : Frame_Type := Frame;
   begin
      while Current /= null loop
         if Current.Pc >= From and Current.Pc <= To then
            return True;
         end if;
         Current := Current.Parent;
      end loop;
      return False;
   end In_Function;

   --  ------------------------------
   --  Check whether the inner most frame contains a call to the function described by
   --  the address range.  This function looks only at the inner most frame and not the
   --  whole stack frame.
   --  ------------------------------
   function By_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean is
   begin
      return Frame /= null and then Frame.Pc >= From and then Frame.Pc <= To;
   end By_Function;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014, 2015, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;

package body MAT.Frames is

   use type MAT.Types.Target_Addr;

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   --  ------------------------------
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table is
      Length  : Natural;
   begin
      if Max_Level > 0 and Max_Level < Frame.Depth then
         Length := Max_Level;
      else
         Length := Frame.Depth;
      end if;
      declare
         Current : Frame_Type := Frame;
         Pos     : Natural    := Length;
         Pc      : Frame_Table (1 .. Length);
      begin
         while Current /= null and Pos /= 0 loop
            Pc (Pos) := Current.Pc;
            Pos := Pos - 1;
            Current := Current.Parent;
         end loop;
         return Pc;
      end;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Pc;
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame '(Parent => null, Depth => 0, Pc => 0, others => <>);
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Frame.Children := F.Next;
         Destroy (F);
      end loop;
      Free (Frame);
   end Destroy;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F.Children;
      Parent        : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
   begin
      while Pos <= Pc'Last loop
         Current_Depth := Current_Depth + 1;
         Child := new Frame '(Parent      => Parent,
                              Next        => Child,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Pc          => Pc (Pos));
         Pos := Pos + 1;
         Parent.Children := Child;
         Parent := Child;
         Child := null;
      end loop;
      Result := Parent;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Parent  : Frame_Type := Frame;
      Current : Frame_Type := Frame.Children;
      Pos     : Positive  := Pc'First;
      Addr    : MAT.Types.Target_Addr;
   begin
      if Pc'Length = 0 then
         Result := Frame;
         Frame.Used := Frame.Used + 1;
         return;
      end if;
      if Current = null then
         Frame.Used := Frame.Used + 1;
         Add_Frame (Frame, Pc, Result);
         return;
      end if;
      Addr := Pc (Pos);
      loop
         if Addr = Current.Pc then
            Parent.Used := Parent.Used + 1;
            Pos  := Pos + 1;
            if Pos > Pc'Last then
               Current.Used := Current.Used + 1;
               Result := Current;
               return;
            end if;
            if Current.Children = null then
               Current.Used := Current.Used + 1;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Parent := Current;
            Current := Current.Children;
            Addr := Pc (Pos);

         elsif Current.Next = null then
            Parent.Used := Parent.Used + 1;
            Add_Frame (Parent, Pc (Pos .. Pc'Last), Result);
            return;
         else
            Current := Current.Next;
         end if;
      end loop;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Pc = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
--     function Find (Frame : in Frame_Type;
--                    Pc    : in Frame_Table) return Frame_Type is
--        Child : Frame_Type := Frame;
--        Pos   : Positive  := Pc'First;
--     begin
--        while Pos <= Pc'Last loop
--           Child := Find (Child, Pc (Pos));
--           Pos  := Pos + 1;
--           --  All the PC of the child frame must match.
--           while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
--              if Child.Calls (Lpos) /= Pc (Pos) then
--                 raise Not_Found;
--              end if;
--              Lpos := Lpos + 1;
--              Pos  := Pos + 1;
--           end loop;
--        end loop;
--        return Child;
--     end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
--     --  ------------------------------
--     procedure Find (Frame   : in Frame_Type;
--                     Pc      : in Frame_Table;
--                     Result  : out Frame_Type;
--                     Last_Pc : out Natural) is
--        Current : Frame_Type := Frame;
--        Pos     : Positive  := Pc'First;
--        Lpos    : Positive;
--     begin
--        Main_Search :
--        while Pos <= Pc'Last loop
--           declare
--              Addr  : constant MAT.Types.Target_Addr := Pc (Pos);
--              Child : Frame_Type  := Current.Children;
--           begin
--              --  Find the child which has the corresponding PC.
--              loop
--                 exit Main_Search when Child = null;
--                 exit when Child.Pc = Addr;
--                 Child := Child.Next;
--              end loop;
--
--              Current := Child;
--              Pos  := Pos + 1;
--              Lpos := 2;
--              --  All the PC of the child frame must match.
--              while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
--                 exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
--                 Lpos := Lpos + 1;
--                 Pos  := Pos + 1;
--              end loop;
--           end;
--        end loop Main_Search;
--        Result := Current;
--        if Pos > Pc'Last then
--           Last_Pc := 0;
--        else
--           Last_Pc := Pos;
--        end if;
--     end Find;

   --  ------------------------------
   --  Check whether the frame contains a call to the function described by the address range.
   --  ------------------------------
   function In_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean is
      Current : Frame_Type := Frame;
   begin
      while Current /= null loop
         if Current.Pc >= From and Current.Pc <= To then
            return True;
         end if;
         Current := Current.Parent;
      end loop;
      return False;
   end In_Function;

   --  ------------------------------
   --  Check whether the inner most frame contains a call to the function described by
   --  the address range.  This function looks only at the inner most frame and not the
   --  whole stack frame.
   --  ------------------------------
   function By_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean is
   begin
      return Frame /= null and then Frame.Pc >= From and then Frame.Pc <= To;
   end By_Function;

end MAT.Frames;

Fix the Used counter that was not incremented correctly


-----------------------------------------------------------------------
--  awa-events-queues -- AWA Event Queues
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Refs;

with EL.Beans;
with EL.Contexts;

with AWA.Events.Models;
package AWA.Events.Queues is

   type Queue_Ref is tagged private;

   --  Queue the event.
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class);

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class));

   --  Returns true if the reference does not contain any element.
   function Is_Null (Queue : in Queue_Ref'Class) return Boolean;
   --  pragma Inline_Always (Is_Null);  SCz 2012-03-17: disabled since gnat crashes.

   --  Returns the queue name.
   function Get_Name (Queue : in Queue_Ref'Class) return String;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref;

   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref;

   function Null_Queue return Queue_Ref;

private

   type Queue is limited interface;
   type Queue_Access is access all Queue'Class;

   --  Get the queue name.
   function Get_Name (From : in Queue) return String is abstract;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (From : in Queue) return AWA.Events.Models.Queue_Ref is abstract;

   --  Queue the event.
   procedure Enqueue (Into  : in out Queue;
                      Event : in AWA.Events.Module_Event'Class) is abstract;

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in out Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is abstract;

   --  Release the queue storage.
   procedure Finalize (From : in out Queue) is null;

   type Queue_Info (Length : Natural) is new Util.Refs.Ref_Entity with record
      Queue : Queue_Access := null;
      Name  : String (1 .. Length);
   end record;
   type Queue_Info_Access is access all Queue_Info;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out Queue_Info);

   package Queue_Refs is
     new Util.Refs.Indefinite_References (Queue_Info, Queue_Info_Access);

   type Queue_Ref is new Queue_Refs.Ref with null record;

end AWA.Events.Queues;

-----------------------------------------------------------------------
--  awa-events-queues -- AWA Event Queues
--  Copyright (C) 2012, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

private with Util.Refs;

with EL.Beans;
with EL.Contexts;

with AWA.Events.Models;
package AWA.Events.Queues is

   type Queue_Ref is tagged private;

   --  Queue the event.
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class);

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class));

   --  Returns true if the queue is available.
   function Has_Queue (Queue : in Queue_Ref'Class) return Boolean;

   --  Returns the queue name.
   function Get_Name (Queue : in Queue_Ref'Class) return String;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref;

   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref;

   function Null_Queue return Queue_Ref;

private

   type Queue is limited interface;
   type Queue_Access is access all Queue'Class;

   --  Get the queue name.
   function Get_Name (From : in Queue) return String is abstract;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (From : in Queue) return AWA.Events.Models.Queue_Ref is abstract;

   --  Queue the event.
   procedure Enqueue (Into  : in out Queue;
                      Event : in AWA.Events.Module_Event'Class) is abstract;

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in out Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is abstract;

   --  Release the queue storage.
   procedure Finalize (From : in out Queue) is null;

   type Queue_Info (Length : Natural) is new Util.Refs.Ref_Entity with record
      Queue : Queue_Access := null;
      Name  : String (1 .. Length);
   end record;
   type Queue_Info_Access is access all Queue_Info;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out Queue_Info);

   package Queue_Refs is
     new Util.Refs.Indefinite_References (Queue_Info, Queue_Info_Access);

   subtype Queue_Info_Accessor is Queue_Refs.Element_Accessor;

   type Queue_Ref is new Queue_Refs.Ref with null record;

end AWA.Events.Queues;

Change Is_Null into Has_Queue and define Queue_Info_Accessor


-----------------------------------------------------------------------
--  Sessions Tests - Unit tests for ASF.Sessions
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      declare
         Dispatcher : constant Request_Dispatcher
           := Ctx.Get_Request_Dispatcher (Path => "/home/test.jsf");
         Req        : ASF.Requests.Mockup.Request;
         Resp       : ASF.Responses.Mockup.Response;
         Result     : Unbounded_String;
      begin
         T.Assert (Dispatcher.Mapping /= null, "No mapping found");

         Req.Set_Request_URI ("test1");
         Req.Set_Method ("GET");
         Forward (Dispatcher, Req, Resp);

         --  Check the response after the Test_Servlet1.Do_Get method execution.
         Resp.Read_Content (Result);
         Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
         Assert_Equals (T, "URI: test1", Result, "Invalid content");

         Req.Set_Method ("POST");
         Forward (Dispatcher, Req, Resp);

         Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                        "Invalid status for an operation not implemented");

      end;
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access) is
      Map : constant Mapping_Access := Ctx.Find_Mapping (URI);
   begin
      if Map = null then
         T.Assert (Server = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Server /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Map.Servlet = Server, "Invalid mapping returned for URI: " & URI);
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      Map : Mapping_Access;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (extension)");
      end;

      T.Assert (Map /= null, "No mapping for 'joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (path)");
      end;

      T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

   package Caller is new Util.Test_Caller (Test, "Servlets");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

-----------------------------------------------------------------------
--  Sessions Tests - Unit tests for ASF.Sessions
--  Copyright (C) 2010, 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Mapping /= null, "No mapping found");

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "", "/home/test.jsf");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access) is
      Map : constant Mapping_Access := Ctx.Find_Mapping (URI);
   begin
      if Map = null then
         T.Assert (Server = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Server /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Map.Servlet = Server, "Invalid mapping returned for URI: " & URI);
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      Map : Mapping_Access;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (extension)");
      end;

      T.Assert (Map /= null, "No mapping for 'joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (path)");
      end;

      T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

   package Caller is new Util.Test_Caller (Test, "Servlets");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

Add a unit test to check the request servlet path


-----------------------------------------------------------------------
--  strings.tests -- Unit tests for Strings
--  Copyright (C) 2009, 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Tests;

package Util.Strings.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

end Util.Strings.Tests;

-----------------------------------------------------------------------
--  strings.tests -- Unit tests for Strings
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Tests;

package Util.Strings.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);
   procedure Test_Starts_With (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

end Util.Strings.Tests;

Declare the Test_Starts_With procedure

Declare the Test_Starts_With procedure


-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;

with ASF.Contexts.Faces;
with ASF.Applications.Main.Configs;

with Security.Permissions;
with Security.Controllers.Roles;
with AWA.Permissions.Configs;
with AWA.Events.Configs;
with AWA.Services.Contexts;

package body AWA.Applications.Configs is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Applications.Configs");

   --  ------------------------------
   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   --  ------------------------------
   package body Reader_Config is
      App_Access : constant ASF.Contexts.Faces.Application_Access := App.all'Unchecked_Access;
      Sec        : constant Security.Permissions.Permission_Manager_Access
        := App.Get_Permission_Manager;

      package Bean_Config is
        new ASF.Applications.Main.Configs.Reader_Config (Reader, App_Access,
                                                         Context.all'Access);
      package Policy_Config is
        new Security.Permissions.Reader_Config (Reader, Sec);
      package Role_Config is
        new Security.Controllers.Roles.Reader_Config (Reader, Sec);
      package Entity_Config is
        new AWA.Permissions.Configs.Reader_Config (Reader, Sec);
      package Event_Config is
        new AWA.Events.Configs.Reader_Config (Reader  => Reader,
                                              Manager => App.Events'Unchecked_Access,
                                              Context => Context.all'Access);

      pragma Warnings (Off, Bean_Config);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Role_Config);
      pragma Warnings (Off, Entity_Config);
      pragma Warnings (Off, Event_Config);
   end Reader_Config;

   --  ------------------------------
   --  Read the application configuration file and configure the application
   --  ------------------------------
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access) is

      Reader : Util.Serialize.IO.XML.Parser;
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Reading application configuration file {0}", File);
      Ctx.Set_Context (App'Unchecked_Access, null);

      declare
         package Config is new Reader_Config (Reader, App'Unchecked_Access, Context);
         pragma Warnings (Off, Config);
      begin
         --  Initialize the parser with the module configuration mappers (if any).
         Initialize_Parser (App, Reader);

         if Log.Get_Level >= Util.Log.DEBUG_LEVEL then
            Util.Serialize.IO.Dump (Reader, Log);
         end if;

         --  Read the configuration file and record managed beans, navigation rules.
         Reader.Parse (File);
      end;
   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

end AWA.Applications.Configs;

-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;

with ASF.Contexts.Faces;
with ASF.Applications.Main.Configs;

with Security.Policies;
with AWA.Events.Configs;
with AWA.Services.Contexts;

package body AWA.Applications.Configs is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Applications.Configs");

   --  ------------------------------
   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   --  ------------------------------
   package body Reader_Config is
      App_Access : constant ASF.Contexts.Faces.Application_Access := App.all'Unchecked_Access;
      Sec        : constant Security.Policies.Policy_Manager_Access
        := App.Get_Security_Manager;

      package Bean_Config is
        new ASF.Applications.Main.Configs.Reader_Config (Reader, App_Access,
                                                         Context.all'Access);
      package Policy_Config is
        new Security.Policies.Reader_Config (Reader, Sec);
      package Event_Config is
        new AWA.Events.Configs.Reader_Config (Reader  => Reader,
                                              Manager => App.Events'Unchecked_Access,
                                              Context => Context.all'Access);

      pragma Warnings (Off, Bean_Config);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Event_Config);
   end Reader_Config;

   --  ------------------------------
   --  Read the application configuration file and configure the application
   --  ------------------------------
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access) is

      Reader : Util.Serialize.IO.XML.Parser;
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Reading application configuration file {0}", File);
      Ctx.Set_Context (App'Unchecked_Access, null);

      declare
         package Config is new Reader_Config (Reader, App'Unchecked_Access, Context);
         pragma Warnings (Off, Config);
      begin
         --  Initialize the parser with the module configuration mappers (if any).
         Initialize_Parser (App, Reader);

         if Log.Get_Level >= Util.Log.DEBUG_LEVEL then
            Util.Serialize.IO.Dump (Reader, Log);
         end if;

         --  Read the configuration file and record managed beans, navigation rules.
         Reader.Parse (File);
      end;
   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

end AWA.Applications.Configs;

Use the Security.Policies to configure the security permissions


-----------------------------------------------------------------------
--  ado-queries-tests -- Test loading of database queries
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "ADO.Queries");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Query",
                       Test_Set_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Limit",
                       Test_Set_Limit'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;
      use type ADO.Drivers.Driver_Index;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager       : Query_Manager;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Manager, Config);

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null and then Manager.Driver = Mysql_Driver.Get_Driver_Index then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager,
                                                          False);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index' (MySQL driver)");
         end;
      end if;
      if Sqlite_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager, False);
         begin
            Assert_Equals (T, "select 0", SQL, "Invalid query for 'index' (SQLite driver)");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager : Query_Manager;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Manager, Config);
      --  T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      --  T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
--        Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
--        T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

   --  ------------------------------
   --  Test the Set_Query operation.
   --  ------------------------------
   procedure Test_Set_Query (T : in out Test) is
      Query : ADO.Queries.Context;
      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Manager : Query_Manager;
      Config        : ADO.Drivers.Connections.Configuration;
   begin
      ADO.Queries.Loaders.Initialize (Manager, Config);
      Query.Set_Query ("simple-query");

      declare
         SQL : constant String := Query.Get_SQL (Manager);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;
   end Test_Set_Query;

   --  ------------------------------
   --  Test the Set_Limit operation.
   --  ------------------------------
   procedure Test_Set_Limit (T : in out Test) is
      Query : ADO.Queries.Context;
      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager : Query_Manager;
   begin
      ADO.Queries.Loaders.Initialize (Manager, Config);
      Query.Set_Query ("index");
      Query.Set_Limit (0, 10);
      Assert_Equals (T, 0, Query.Get_First_Row_Index, "Invalid first row index");
      Assert_Equals (T, 10, Query.Get_Last_Row_Index, "Invalid last row index");
   end Test_Set_Limit;

end ADO.Queries.Tests;

-----------------------------------------------------------------------
--  ado-queries-tests -- Test loading of database queries
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "ADO.Queries");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Query",
                       Test_Set_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Limit",
                       Test_Set_Limit'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;
      use type ADO.Drivers.Driver_Index;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager       : Query_Manager;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Manager, Config);

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null and then Manager.Driver = Mysql_Driver.Get_Driver_Index then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager,
                                                          False);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index' (MySQL driver)");
         end;
      end if;
      if Sqlite_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager, False);
         begin
            Assert_Equals (T, "select 0", SQL, "Invalid query for 'index' (SQLite driver)");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager : Query_Manager;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Manager, Config);
      --  T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      --  T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
--        Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
--        T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

   --  ------------------------------
   --  Test the Set_Query operation.
   --  ------------------------------
   procedure Test_Set_Query (T : in out Test) is
      Query : ADO.Queries.Context;
      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Manager : Query_Manager;
      Config        : ADO.Drivers.Connections.Configuration;
   begin
      ADO.Queries.Loaders.Initialize (Manager, Config);
      Query.Set_Query ("simple-query");

      declare
         SQL : constant String := Query.Get_SQL (Manager);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;
   end Test_Set_Query;

   --  ------------------------------
   --  Test the Set_Limit operation.
   --  ------------------------------
   procedure Test_Set_Limit (T : in out Test) is
      Query : ADO.Queries.Context;
   begin
      Query.Set_Query ("index");
      Query.Set_Limit (0, 10);
      Assert_Equals (T, 0, Query.Get_First_Row_Index, "Invalid first row index");
      Assert_Equals (T, 10, Query.Get_Last_Row_Index, "Invalid last row index");
   end Test_Set_Limit;

end ADO.Queries.Tests;

Simplify the unit test

Simplify the unit test


-----------------------------------------------------------------------
--  ADO Objects Tests -- Tests for ADO.Objects
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with ADO.Sessions;
with Regtests.Simple.Model;
with Regtests.Comments;
package body ADO.Objects.Tests is

   use Util.Tests;
   use type Ada.Containers.Hash_Type;

   function Get_Allocate_Key (N : Identifier) return Object_Key;

   function Get_Allocate_Key (N : Identifier) return Object_Key is
      Result : Object_Key (Of_Type  => KEY_INTEGER,
                           Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
   begin
      Set_Value (Result, N);
      return Result;
   end Get_Allocate_Key;

   --  ------------------------------
   --  Various tests on Hash and key comparison
   --  ------------------------------
   procedure Test_Key (T : in out Test) is
      K1 : constant Object_Key := Get_Allocate_Key (1);
      K2 : Object_Key (Of_Type  => KEY_STRING,
                       Of_Class => Regtests.Simple.Model.USER_TABLE'Access);
      K3 : Object_Key := K1;
      K4 : Object_Key (Of_Type  => KEY_INTEGER,
                       Of_Class => Regtests.Simple.Model.USER_TABLE'Access);
   begin
      T.Assert (not (K1 = K2), "Key on different tables must be different");
      T.Assert (not (K2 = K4), "Key with different type must be different");
      T.Assert (K1 = K3, "Keys are identical");
      T.Assert (Equivalent_Elements (K1, K3), "Keys are identical");
      T.Assert (Equivalent_Elements (K3, K1), "Keys are identical");

      T.Assert (Hash (K1) = Hash (K3), "Hash of identical keys should be identical");

      Set_Value (K3, 2);
      T.Assert (not (K1 = K3), "Keys should be different");
      T.Assert (Hash (K1) /= Hash (K3), "Hash should be different");
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");

      Set_Value (K4, 1);
      T.Assert (Hash (K1) /= Hash (K4),
               "Hash on key with same value and different tables should be different");
      T.Assert (not (K4 = K1), "Key on different tables should be different");

      Set_Value (K2, 1);
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");
   end Test_Key;

   --  ------------------------------
   --  Check:
   --    Object_Ref := (reference counting)
   --    Object_Ref.Copy
   --    Object_Ref.Get_xxx generated method
   --    Object_Ref.Set_xxx generated method
   --    Object_Ref.=
   --  ------------------------------
   procedure Test_Object_Ref (T : in out Test) is
      use type Regtests.Simple.Model.User_Ref;
      Obj1     : Regtests.Simple.Model.User_Ref;
      Null_Obj : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Obj1 = Null_Obj, "Two null objects are identical");
      for I in 1 .. 10 loop
         Obj1.Set_Name ("User name");
         T.Assert (Obj1.Get_Name = "User name", "User_Ref.Set_Name invalid result");

         T.Assert (Obj1 /= Null_Obj, "Object is not identical as the null object");
         declare
            Obj2 : constant Regtests.Simple.Model.User_Ref := Obj1;
            Obj3 : Regtests.Simple.Model.User_Ref;
         begin
            Obj1.Copy (Obj3);
            Obj3.Set_Id (2);
            --  Check the copy
            T.Assert (Obj2.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            T.Assert (Obj3 /= Obj1, "Object_Ref.'=' invalid comparison after copy");

            --  Change original, make sure it's the same of Obj2.
            Obj1.Set_Name ("Second name");
            T.Assert (Obj2.Get_Name = "Second name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            --  The copy is not modified
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
         end;
      end loop;
   end Test_Object_Ref;

   --  ------------------------------
   --  Test creation of an object with lazy loading.
   --  ------------------------------
   procedure Test_Create_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
      Cmt  : Regtests.Comments.Comment_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (U2.Get_Name),
                        "Cannot load created object");
         Assert_Equals (T, Integer (0), Integer (U2.Get_Value), "Invalid load");
         T.Assert (User.Get_Key = U2.Get_Key, "Invalid key after load");
      end;

      --  Create a comment for the user.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         Cmt.Set_Message (Ada.Strings.Unbounded.To_Unbounded_String ("A comment from Joe"));
         Cmt.Set_User (User);
         Cmt.Set_Entity_Id (2);
         Cmt.Set_Entity_Type (1);
         Cmt.Set_Date (ADO.DEFAULT_TIME);
         Cmt.Save (S);
         S.Commit;
      end;

      --  Load that comment.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         C2 : Regtests.Comments.Comment_Ref;
      begin
         C2.Load (S, Cmt.Get_Id);
         T.Assert (not C2.Is_Null, "Loading of object failed");
         T.Assert (Cmt.Get_Key = C2.Get_Key, "Invalid key after load");
         T.Assert_Equals ("A comment from Joe", Ada.Strings.Unbounded.To_String (C2.Get_Message),
                          "Invalid message");

         T.Assert (not C2.Get_User.Is_Null, "User associated with the comment should not be null");
--           T.Assert (not C2.Get_Entity_Type.Is_Null, "Entity type was not set");

         --  Check that we can access the user name (lazy load)
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (C2.Get_User.Get_Name),
                        "Cannot load created object");
      end;
   end Test_Create_Object;

   --  ------------------------------
   --  Test creation and deletion of an object record
   --  ------------------------------
   procedure Test_Delete_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe (delete)");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it and delete it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);

         S.Begin_Transaction;
         U2.Delete (S);
         S.Commit;
      end;

      --  Try to load the deleted object.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (False, "Load of a deleted object should raise NOT_FOUND");

      exception
         when ADO.Objects.NOT_FOUND =>
            null;
      end;
   end Test_Delete_Object;

   --  ------------------------------
   --  Test Is_Inserted and Is_Null
   --  ------------------------------
   procedure Test_Is_Inserted (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (not User.Is_Inserted, "A null object should not be marked as INSERTED");
      T.Assert (User.Is_Null, "A null object should be marked as NULL");

      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("John");
         T.Assert (not User.Is_Null, "User should not be NULL");
         T.Assert (not User.Is_Inserted, "User was not saved and not yet inserted in database");

         User.Set_Value (1);
         User.Save (S);
         S.Commit;
         T.Assert (User.Is_Inserted, "After a save operation, the user should be marked INSERTED");
         T.Assert (not User.Is_Null, "User should not be NULL");
      end;

      declare
         S    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         John : Regtests.Simple.Model.User_Ref;
      begin
         John.Load (S, User.Get_Id);
         T.Assert (John.Is_Inserted, "After a load, the object should be marked INSERTED");
         T.Assert (not John.Is_Null, "After a load, the object should not be NULL");
      end;
   end Test_Is_Inserted;

   package Caller is new Util.Test_Caller (Test, "ADO.Objects");

   --  ------------------------------
   --  Add the tests in the test suite
   --  ------------------------------
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Objects.Hash", Test_Key'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Get/Set", Test_Object_Ref'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Create", Test_Create_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Delete", Test_Delete_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Is_Created", Test_Is_Inserted'Access);
   end Add_Tests;

end ADO.Objects.Tests;

-----------------------------------------------------------------------
--  ADO Objects Tests -- Tests for ADO.Objects
--  Copyright (C) 2011, 2012, 2013, 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with ADO.Sessions;
with Regtests.Simple.Model;
with Regtests.Comments;
package body ADO.Objects.Tests is

   use Util.Tests;
   use type Ada.Containers.Hash_Type;

   function Get_Allocate_Key (N : Identifier) return Object_Key;

   function Get_Allocate_Key (N : Identifier) return Object_Key is
      Result : Object_Key (Of_Type  => KEY_INTEGER,
                           Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
   begin
      Set_Value (Result, N);
      return Result;
   end Get_Allocate_Key;

   --  ------------------------------
   --  Various tests on Hash and key comparison
   --  ------------------------------
   procedure Test_Key (T : in out Test) is
      K1 : constant Object_Key := Get_Allocate_Key (1);
      K2 : Object_Key (Of_Type  => KEY_STRING,
                       Of_Class => Regtests.Simple.Model.USER_TABLE'Access);
      K3 : Object_Key := K1;
      K4 : Object_Key (Of_Type  => KEY_INTEGER,
                       Of_Class => Regtests.Simple.Model.USER_TABLE'Access);
   begin
      T.Assert (not (K1 = K2), "Key on different tables must be different");
      T.Assert (not (K2 = K4), "Key with different type must be different");
      T.Assert (K1 = K3, "Keys are identical");
      T.Assert (Equivalent_Elements (K1, K3), "Keys are identical");
      T.Assert (Equivalent_Elements (K3, K1), "Keys are identical");

      T.Assert (Hash (K1) = Hash (K3), "Hash of identical keys should be identical");

      Set_Value (K3, 2);
      T.Assert (not (K1 = K3), "Keys should be different");
      T.Assert (Hash (K1) /= Hash (K3), "Hash should be different");
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");

      Set_Value (K4, 1);
      T.Assert (Hash (K1) /= Hash (K4),
               "Hash on key with same value and different tables should be different");
      T.Assert (not (K4 = K1), "Key on different tables should be different");

      Set_Value (K2, 1);
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");
   end Test_Key;

   --  ------------------------------
   --  Check:
   --    Object_Ref := (reference counting)
   --    Object_Ref.Copy
   --    Object_Ref.Get_xxx generated method
   --    Object_Ref.Set_xxx generated method
   --    Object_Ref.=
   --  ------------------------------
   procedure Test_Object_Ref (T : in out Test) is
      use type Regtests.Simple.Model.User_Ref;
      Obj1     : Regtests.Simple.Model.User_Ref;
      Null_Obj : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Obj1 = Null_Obj, "Two null objects are identical");
      for I in 1 .. 10 loop
         Obj1.Set_Name ("User name");
         T.Assert (Obj1.Get_Name = "User name", "User_Ref.Set_Name invalid result");

         T.Assert (Obj1 /= Null_Obj, "Object is not identical as the null object");
         declare
            Obj2 : constant Regtests.Simple.Model.User_Ref := Obj1;
            Obj3 : Regtests.Simple.Model.User_Ref;
         begin
            Obj1.Copy (Obj3);
            Obj3.Set_Id (2);
            --  Check the copy
            T.Assert (Obj2.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            T.Assert (Obj3 /= Obj1, "Object_Ref.'=' invalid comparison after copy");

            --  Change original, make sure it's the same of Obj2.
            Obj1.Set_Name ("Second name");
            T.Assert (Obj2.Get_Name = "Second name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            --  The copy is not modified
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
         end;
      end loop;
   end Test_Object_Ref;

   --  ------------------------------
   --  Test creation of an object with lazy loading.
   --  ------------------------------
   procedure Test_Create_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
      Cmt  : Regtests.Comments.Comment_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (U2.Get_Name),
                        "Cannot load created object");
         Assert_Equals (T, Integer (0), Integer (U2.Get_Value), "Invalid load");
         T.Assert (User.Get_Key = U2.Get_Key, "Invalid key after load");
      end;

      --  Create a comment for the user.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         Cmt.Set_Message (Ada.Strings.Unbounded.To_Unbounded_String ("A comment from Joe"));
         Cmt.Set_User (User);
         Cmt.Set_Entity_Id (2);
         Cmt.Set_Entity_Type (1);
         --  Cmt.Set_Date (ADO.DEFAULT_TIME);
         Cmt.Set_Date (Ada.Calendar.Clock);
         Cmt.Save (S);
         S.Commit;
      end;

      --  Load that comment.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         C2 : Regtests.Comments.Comment_Ref;
      begin
         C2.Load (S, Cmt.Get_Id);
         T.Assert (not C2.Is_Null, "Loading of object failed");
         T.Assert (Cmt.Get_Key = C2.Get_Key, "Invalid key after load");
         T.Assert_Equals ("A comment from Joe", Ada.Strings.Unbounded.To_String (C2.Get_Message),
                          "Invalid message");

         T.Assert (not C2.Get_User.Is_Null, "User associated with the comment should not be null");
--           T.Assert (not C2.Get_Entity_Type.Is_Null, "Entity type was not set");

         --  Check that we can access the user name (lazy load)
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (C2.Get_User.Get_Name),
                        "Cannot load created object");
      end;
   end Test_Create_Object;

   --  ------------------------------
   --  Test creation and deletion of an object record
   --  ------------------------------
   procedure Test_Delete_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe (delete)");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it and delete it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);

         S.Begin_Transaction;
         U2.Delete (S);
         S.Commit;
      end;

      --  Try to load the deleted object.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (False, "Load of a deleted object should raise NOT_FOUND");

      exception
         when ADO.Objects.NOT_FOUND =>
            null;
      end;
   end Test_Delete_Object;

   --  ------------------------------
   --  Test Is_Inserted and Is_Null
   --  ------------------------------
   procedure Test_Is_Inserted (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (not User.Is_Inserted, "A null object should not be marked as INSERTED");
      T.Assert (User.Is_Null, "A null object should be marked as NULL");

      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("John");
         T.Assert (not User.Is_Null, "User should not be NULL");
         T.Assert (not User.Is_Inserted, "User was not saved and not yet inserted in database");

         User.Set_Value (1);
         User.Save (S);
         S.Commit;
         T.Assert (User.Is_Inserted, "After a save operation, the user should be marked INSERTED");
         T.Assert (not User.Is_Null, "User should not be NULL");
      end;

      declare
         S    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         John : Regtests.Simple.Model.User_Ref;
      begin
         John.Load (S, User.Get_Id);
         T.Assert (John.Is_Inserted, "After a load, the object should be marked INSERTED");
         T.Assert (not John.Is_Null, "After a load, the object should not be NULL");
      end;
   end Test_Is_Inserted;

   package Caller is new Util.Test_Caller (Test, "ADO.Objects");

   --  ------------------------------
   --  Add the tests in the test suite
   --  ------------------------------
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Objects.Hash", Test_Key'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Get/Set", Test_Object_Ref'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Create", Test_Create_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Delete", Test_Delete_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Is_Created", Test_Is_Inserted'Access);
   end Add_Tests;

end ADO.Objects.Tests;

Fix the unit test for the setting of a time stamp