-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  Copyright (C) 2014, 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.Log.Loggers;

with MAT.Memory.Probes;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Memory_Probe : constant MAT.Memory.Probes.Memory_Probe_Type_Access
        := new MAT.Memory.Probes.Memory_Probe_Type;
   begin
      Memory_Probe.Data := Memory'Unrestricted_Access;
      MAT.Memory.Probes.Register (Manager, Memory_Probe);
   end Initialize;

   --  ------------------------------
   --  Add the memory region from the list of memory region managed by the program.
   --  ------------------------------
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info) is
   begin
      Log.Info ("Add region [" & MAT.Types.Hex_Image (Region.Start_Addr) & "-"
                  & MAT.Types.Hex_Image (Region.End_Addr) & "] - {0}", Region.Path);
      Memory.Memory.Add_Region (Region);
   end Add_Region;

   --  ------------------------------
   --  Find the memory region that intersect the given section described by <tt>From</tt>
   --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
   --  map.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Region_Info_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  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 Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Collect the information about frames and the memory allocations they've made.
   --  ------------------------------
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map) is
   begin
      Memory.Memory.Frame_Information (Level, Frames);
   end Frame_Information;

   --  ------------------------------
   --  Get the global memory and allocation statistics.
   --  ------------------------------
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat) is
   begin
      Memory.Memory.Stat_Information (Result);
   end Stat_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Add the memory region from the list of memory region managed by the program.
      --  ------------------------------
      procedure Add_Region (Region : in Region_Info) is
      begin
         Regions.Insert (Region.Start_Addr, Region);
      end Add_Region;

      --  ------------------------------
      --  Find the memory region that intersect the given section described by <tt>From</tt>
      --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
      --  map.
      --  ------------------------------
      procedure Find (From : in MAT.Types.Target_Addr;
                      To   : in MAT.Types.Target_Addr;
                      Into : in out MAT.Memory.Region_Info_Map) is
         Iter : Region_Info_Cursor;
      begin
         Iter := Regions.Ceiling (From);
         while Region_Info_Maps.Has_Element (Iter) loop
            declare
               Start  : constant MAT.Types.Target_Addr := Region_Info_Maps.Key (Iter);
               Region : Region_Info;
            begin
               exit when Start > To;

               Region := Region_Info_Maps.Element (Iter);
               if Region.End_Addr >= From then
                  if not Into.Contains (Start) then
                     Into.Insert (Start, Region);
                  end if;
               end if;
               Region_Info_Maps.Next (Iter);
            end;
         end loop;
      end Find;

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  if Stats.Total_Free > Slot.Size then
                     Stats.Total_Free := Stats.Total_Free - Slot.Size;
                  else
                     Stats.Total_Free := 0;
                  end if;
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Malloc_Count := Stats.Malloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Remove_Free (Addr, Slot.Size);
            Used_Slots.Insert (Addr, Slot);
         end if;
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Stats.Free_Count := Stats.Free_Count + 1;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            if Stats.Total_Alloc >= Item.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Item.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Stats.Total_Free := Stats.Total_Free + Item.Size;
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Iter := Freed_Slots.Find (Addr);
            if not Allocation_Maps.Has_Element (Iter) then
               Freed_Slots.Insert (Addr, Item);
            end if;
         end if;

      exception
         when others =>
            Log.Error ("Free {0} raised some exception", MAT.Types.Hex_Image (Addr));
            raise;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            if Stats.Total_Alloc >= Element.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Element.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Realloc_Count := Stats.Realloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  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 Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Collect the information about frames and the memory allocations they've made.
      --  ------------------------------
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map) is
      begin
         MAT.Memory.Tools.Frame_Information (Used_Slots, Level, Frames);
      end Frame_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

      --  ------------------------------
      --  Get the global memory and allocation statistics.
      --  ------------------------------
      procedure Stat_Information (Result : out Memory_Stat) is
      begin
         Result := Stats;
      end Stat_Information;

   end Memory_Allocator;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  Copyright (C) 2014, 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.Log.Loggers;

with MAT.Memory.Probes;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Memory_Probe : constant MAT.Memory.Probes.Memory_Probe_Type_Access
        := new MAT.Memory.Probes.Memory_Probe_Type;
   begin
      Memory_Probe.Data := Memory'Unrestricted_Access;
      MAT.Memory.Probes.Register (Manager, Memory_Probe);
   end Initialize;

   --  ------------------------------
   --  Add the memory region from the list of memory region managed by the program.
   --  ------------------------------
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info) is
   begin
      Log.Info ("Add region [" & MAT.Types.Hex_Image (Region.Start_Addr) & "-"
                  & MAT.Types.Hex_Image (Region.End_Addr) & "] - {0}", Region.Path);
      Memory.Memory.Add_Region (Region);
   end Add_Region;

   --  ------------------------------
   --  Find the memory region that intersect the given section described by <tt>From</tt>
   --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
   --  map.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Region_Info_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in out Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  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 Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Collect the information about frames and the memory allocations they've made.
   --  ------------------------------
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map) is
   begin
      Memory.Memory.Frame_Information (Level, Frames);
   end Frame_Information;

   --  ------------------------------
   --  Get the global memory and allocation statistics.
   --  ------------------------------
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat) is
   begin
      Memory.Memory.Stat_Information (Result);
   end Stat_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Add the memory region from the list of memory region managed by the program.
      --  ------------------------------
      procedure Add_Region (Region : in Region_Info) is
      begin
         Regions.Insert (Region.Start_Addr, Region);
      end Add_Region;

      --  ------------------------------
      --  Find the memory region that intersect the given section described by <tt>From</tt>
      --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
      --  map.
      --  ------------------------------
      procedure Find (From : in MAT.Types.Target_Addr;
                      To   : in MAT.Types.Target_Addr;
                      Into : in out MAT.Memory.Region_Info_Map) is
         Iter : Region_Info_Cursor;
      begin
         Iter := Regions.Ceiling (From);
         while Region_Info_Maps.Has_Element (Iter) loop
            declare
               Start  : constant MAT.Types.Target_Addr := Region_Info_Maps.Key (Iter);
               Region : Region_Info;
            begin
               exit when Start > To;

               Region := Region_Info_Maps.Element (Iter);
               if Region.End_Addr >= From then
                  if not Into.Contains (Start) then
                     Into.Insert (Start, Region);
                  end if;
               end if;
               Region_Info_Maps.Next (Iter);
            end;
         end loop;
      end Find;

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  if Stats.Total_Free > Slot.Size then
                     Stats.Total_Free := Stats.Total_Free - Slot.Size;
                  else
                     Stats.Total_Free := 0;
                  end if;
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Malloc_Count := Stats.Malloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Remove_Free (Addr, Slot.Size);
            Used_Slots.Insert (Addr, Slot);
         end if;
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in out Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Stats.Free_Count := Stats.Free_Count + 1;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            Slot.Size := Item.Size;
            if Stats.Total_Alloc >= Item.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Item.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Stats.Total_Free := Stats.Total_Free + Item.Size;
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Iter := Freed_Slots.Find (Addr);
            if not Allocation_Maps.Has_Element (Iter) then
               Freed_Slots.Insert (Addr, Item);
            end if;
         end if;

      exception
         when others =>
            Log.Error ("Free {0} raised some exception", MAT.Types.Hex_Image (Addr));
            raise;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            if Stats.Total_Alloc >= Element.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Element.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Realloc_Count := Stats.Realloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  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 Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Collect the information about frames and the memory allocations they've made.
      --  ------------------------------
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map) is
      begin
         MAT.Memory.Tools.Frame_Information (Used_Slots, Level, Frames);
      end Frame_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

      --  ------------------------------
      --  Get the global memory and allocation statistics.
      --  ------------------------------
      procedure Stat_Information (Result : out Memory_Stat) is
      begin
         Result := Stats;
      end Stat_Information;

   end Memory_Allocator;

end MAT.Memory.Targets;

Change Probe_Free to update the Allocation slot and return the size information


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010 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.Properties.Factories;
with Ada.Strings.Unbounded.Text_IO;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, +Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & To_String (Name) & "'";
      end if;

      return Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return -Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return -Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
      Prop_Name : constant Value := +Name;
   begin
      if Exists (Self, Prop_Name) then
         return Get (Self, Prop_Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         Util.Properties.Factories.Initialize (Self);
         Self.Impl.Count := 1;
      elsif Self.Impl.Count > 1 then
         Self.Impl := Create_Copy (Self.Impl.all);
      end if;
   end Check_And_Create_Impl;

   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Insert (Self.Impl.all, +Name, +Item);
   end Insert;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, +Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, Name, Item);
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, Name);
   end Remove;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count - 1;
         if Object.Impl.Count = 0 then
            Delete (Object.Impl.all, Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
         Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name  : out Unbounded_String;
                            Value : out Unbounded_String;
                            File  : in File_Type) is
      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;
            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self : in out Manager'Class;
                              File : in File_Type) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File);
         exit when Name = Null_Unbounded_String;
         Set (Self, To_String (Name), To_String (Value));
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   --  ------------------------------
   procedure Copy (Self : in out Manager'Class;
                   From : in Manager'Class;
                   Prefix : in String := "") is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               Self.Set (Name, From.Get (Name));
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010 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.Properties.Factories;
with Ada.Strings.Unbounded.Text_IO;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, +Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & To_String (Name) & "'";
      end if;

      return Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return -Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return -Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
      Prop_Name : constant Value := +Name;
   begin
      if Exists (Self, Prop_Name) then
         return Get (Self, Prop_Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         Util.Properties.Factories.Initialize (Self);
         Self.Impl.Count := 1;
      elsif Self.Impl.Count > 1 then
         declare
            Old : Interface_P.Manager_Access := Self.Impl;
         begin
            Self.Impl := Create_Copy (Self.Impl.all);
            Self.Impl.Count := 1;
            Old.Count := Old.Count - 1;
         end;
      end if;
   end Check_And_Create_Impl;

   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Insert (Self.Impl.all, +Name, +Item);
   end Insert;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, +Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, Name, Item);
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, Name);
   end Remove;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count - 1;
         if Object.Impl.Count = 0 then
            Delete (Object.Impl.all, Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
         Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name  : out Unbounded_String;
                            Value : out Unbounded_String;
                            File  : in File_Type) is
      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;
            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self : in out Manager'Class;
                              File : in File_Type) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File);
         exit when Name = Null_Unbounded_String;
         Set (Self, To_String (Name), To_String (Value));
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   --  ------------------------------
   procedure Copy (Self : in out Manager'Class;
                   From : in Manager'Class;
                   Prefix : in String := "") is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               Self.Set (Name, From.Get (Name));
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

Fix copy of property manager

Fix copy of property manager


-----------------------------------------------------------------------
--  asf-navigations-tests -  Tests for ASF navigation
--  Copyright (C) 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.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ASF.Applications.Tests;
package body ASF.Navigations.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test navigation exact match (view, outcome, action)",
                       Test_Exact_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation partial match (view, outcome)",
                       Test_Partial_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation exception match (view, outcome)",
                       Test_Exception_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation wildcard match (view, outcome)",
                       Test_Wildcard_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation condition match (view, outcome)",
                       Test_Conditional_Navigation'Access);

   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Check the navigation for an URI and expect the result to match the regular expression.
   --  ------------------------------
   procedure Check_Navigation (T     : in out Test;
                               Name  : in String;
                               Match : in String;
                               Raise_Flag : in Boolean := False) is
      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      File     : constant String := Util.Tests.Get_Path ("regtests/config/test-navigations.xml");
   begin
      Form.Perm_Error := Raise_Flag;
      ASF.Applications.Main.Configs.Read_Configuration (ASF.Tests.Get_Application.all, File);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/" & Name & ".html", Name & ".txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/" & Name & ".html", Name & "form-navigation-exact.txt");
      Assert_Matches (T, Match,
                      Reply, "Wrong generated content");
   end Check_Navigation;

   --  ------------------------------
   --  Test a form navigation with an exact match (view, outcome, action).
   --  ------------------------------
   procedure Test_Exact_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav", ".*success.*");
   end Test_Exact_Navigation;

   --  ------------------------------
   --  Test a form navigation with a partial match (view, outcome).
   --  ------------------------------
   procedure Test_Partial_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-partial", ".*success partial.*");
   end Test_Partial_Navigation;

   --  ------------------------------
   --  Test a form navigation with a exception match (view, outcome).
   --  ------------------------------
   procedure Test_Exception_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-exception", ".*success exception.*", True);
   end Test_Exception_Navigation;

   --  ------------------------------
   --  Test a form navigation with a wildcard match on the URI (view, outcome).
   --  ------------------------------
   procedure Test_Wildcard_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-wildcard", ".*success wildcard.*", False);
   end Test_Wildcard_Navigation;

   --  ------------------------------
   --  Test a form navigation with a condition (view, outcome, condition).
   --  ------------------------------
   procedure Test_Conditional_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-condition", ".*success condition.*", False);
   end Test_Conditional_Navigation;

end ASF.Navigations.Tests;

-----------------------------------------------------------------------
--  asf-navigations-tests -  Tests for ASF navigation
--  Copyright (C) 2013, 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.Test_Caller;
with Util.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ASF.Applications.Tests;
package body ASF.Navigations.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test navigation exact match (view, outcome, action)",
                       Test_Exact_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation partial match (view, outcome)",
                       Test_Partial_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation exception match (view, outcome)",
                       Test_Exception_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation wildcard match (view, outcome)",
                       Test_Wildcard_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation condition match (view, outcome)",
                       Test_Conditional_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation with status",
                       Test_Status_Navigation'Access);

   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Check the navigation for an URI and expect the result to match the regular expression.
   --  ------------------------------
   procedure Check_Navigation (T          : in out Test;
                               Name       : in String;
                               Match      : in String;
                               Raise_Flag : in Boolean := False;
                               Status     : in Natural := 200) is
      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      File     : constant String := Util.Tests.Get_Path ("regtests/config/test-navigations.xml");
   begin
      Form.Perm_Error := Raise_Flag;
      ASF.Applications.Main.Configs.Read_Configuration (ASF.Tests.Get_Application.all, File);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/" & Name & ".html", Name & ".txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/" & Name & ".html", Name & "form-navigation-exact.txt");
      Assert_Matches (T, Match,
                      Reply, "Wrong generated content", Status);
   end Check_Navigation;

   --  ------------------------------
   --  Test a form navigation with an exact match (view, outcome, action).
   --  ------------------------------
   procedure Test_Exact_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav", ".*success.*");
   end Test_Exact_Navigation;

   --  ------------------------------
   --  Test a form navigation with a partial match (view, outcome).
   --  ------------------------------
   procedure Test_Partial_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-partial", ".*success partial.*");
   end Test_Partial_Navigation;

   --  ------------------------------
   --  Test a form navigation with a exception match (view, outcome).
   --  ------------------------------
   procedure Test_Exception_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-exception", ".*success exception.*", True);
   end Test_Exception_Navigation;

   --  ------------------------------
   --  Test a form navigation with a wildcard match on the URI (view, outcome).
   --  ------------------------------
   procedure Test_Wildcard_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-wildcard", ".*success wildcard.*", False);
   end Test_Wildcard_Navigation;

   --  ------------------------------
   --  Test a form navigation with a condition (view, outcome, condition).
   --  ------------------------------
   procedure Test_Conditional_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-condition", ".*success condition.*", False);
   end Test_Conditional_Navigation;

   --  ------------------------------
   --  Test a navigation rule with a status.
   --  ------------------------------
   procedure Test_Status_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-status", ".*success status.*", False, 400);
   end Test_Status_Navigation;

end ASF.Navigations.Tests;

Add new unit test Test_Status_Navigation to test the <status> configuration of a navigation rule


-----------------------------------------------------------------------
--  xrds -- XRDS parser example
--  Copyright (C) 2010, 2011 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.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Command_Line;
with Ada.Containers;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Beans;
with Util.Beans.Objects;
with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.Mappers.Vector_Mapper;
with Util.Serialize.IO.XML;
procedure Xmlrd is

   use Ada.Containers;
   use Util.Streams.Buffered;
   use Ada.Strings.Unbounded;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type Service_Fields is (FIELD_PRIORITY, FIELD_TYPE, FIELD_URI, FIELD_LOCAL_ID, FIELD_DELEGATE);

   type Service is record
      Priority : Integer;
      URI      : Ada.Strings.Unbounded.Unbounded_String;
      RDS_Type : Ada.Strings.Unbounded.Unbounded_String;
      Delegate : Ada.Strings.Unbounded.Unbounded_String;
      Local_Id : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Service_Access is access all Service;

   package Service_Vector is
     new Ada.Containers.Vectors (Element_Type => Service,
                                 Index_Type   => Natural);

   procedure Print (P : in Service_Vector.Cursor);
   procedure Print (P : in Service);
   procedure Set_Member (P     : in out Service;
                         Field : in Service_Fields;
                         Value : in Util.Beans.Objects.Object);
   function Get_Member (P     : in Service;
                        Field : in Service_Fields) return Util.Beans.Objects.Object;

   procedure Set_Member (P     : in out Service;
                         Field : in Service_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      Ada.Text_IO.Put_Line ("Set member " & Service_Fields'Image (Field)
                            & " to " & Util.Beans.Objects.To_String (Value));
      case Field is
         when FIELD_PRIORITY =>
            P.Priority := Util.Beans.Objects.To_Integer (Value);

         when FIELD_TYPE =>
            P.RDS_Type := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_URI =>
            P.URI := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCAL_ID =>
            P.Local_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_DELEGATE =>
            P.Delegate := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   function Get_Member (P : in Service;
                        Field : in Service_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_PRIORITY =>
            return Util.Beans.Objects.To_Object (P.Priority);

         when FIELD_TYPE =>
            return Util.Beans.Objects.To_Object (P.RDS_Type);

         when FIELD_URI =>
            return Util.Beans.Objects.To_Object (P.URI);

         when FIELD_LOCAL_ID =>
            return Util.Beans.Objects.To_Object (P.Local_Id);

         when FIELD_DELEGATE =>
            return Util.Beans.Objects.To_Object (P.Delegate);

      end case;
   end Get_Member;

   package Service_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Service,
                                               Element_Type_Access => Service_Access,
                                               Fields              => Service_Fields,
                                               Set_Member          => Set_Member);

   package Service_Vector_Mapper is
     new Util.Serialize.Mappers.Vector_Mapper (Vectors        => Service_Vector,
                                               Element_Mapper => Service_Mapper);

   procedure Print (P : in Service) is
   begin
      Ada.Text_IO.Put_Line ("        URI: " & To_String (P.URI));
      Ada.Text_IO.Put_Line ("   Priority: " & Integer'Image (P.Priority));
      Ada.Text_IO.Put_Line ("Type (last): " & To_String (P.RDS_Type));
      Ada.Text_IO.Put_Line ("   Delegate: " & To_String (P.Delegate));
      Ada.Text_IO.New_Line;
   end Print;

   procedure Print (P : in Service_Vector.Cursor) is
   begin
      Print (Service_Vector.Element (P));
   end Print;

   Service_Mapping        : aliased Service_Mapper.Mapper;
   Service_Vector_Mapping : aliased Service_Vector_Mapper.Mapper;

begin
   Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmlrd file...");
      return;
   end if;

   Service_Mapping.Add_Mapping ("Type", FIELD_TYPE);
   Service_Mapping.Add_Mapping ("URI", FIELD_URI);
   Service_Mapping.Add_Mapping ("Delegate", FIELD_DELEGATE);
   Service_Mapping.Add_Mapping ("@priority", FIELD_PRIORITY);
   Service_Mapping.Bind (Get_Member'Access);
   Service_Vector_Mapping.Set_Mapping (Service_Mapping'Unchecked_Access);

   Reader.Add_Mapping ("XRDS/XRD/Service", Service_Vector_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);

         List : aliased Service_Vector_Mapper.Vector;
      begin
         Service_Vector_Mapper.Set_Context (Reader, List'Unchecked_Access);
         Reader.Parse (S);

         Ada.Text_IO.Put_Line ("Rule count: " & Count_Type'Image (List.Length));

         --  The list now contains our elements.
         List.Iterate (Process => Print'Access);

         declare
            Output : Util.Serialize.IO.XML.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Output.Start_Entity ("XRDS");
            Service_Vector_Mapping.Write (Output, List);
            Output.End_Entity ("XRDS");
            Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;
      end;
   end loop;
end Xmlrd;

-----------------------------------------------------------------------
--  xrds -- XRDS parser example
--  Copyright (C) 2010, 2011 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.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Command_Line;
with Ada.Containers;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Beans;
with Util.Beans.Objects;
with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.Mappers.Vector_Mapper;
with Util.Serialize.IO.XML;
procedure Xmlrd is

   use Ada.Containers;
   use Util.Streams.Buffered;
   use Ada.Strings.Unbounded;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type Service_Fields is (FIELD_PRIORITY, FIELD_TYPE, FIELD_URI, FIELD_LOCAL_ID, FIELD_DELEGATE);

   type Service is record
      Priority : Integer;
      URI      : Ada.Strings.Unbounded.Unbounded_String;
      RDS_Type : Ada.Strings.Unbounded.Unbounded_String;
      Delegate : Ada.Strings.Unbounded.Unbounded_String;
      Local_Id : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Service_Access is access all Service;

   package Service_Vector is
     new Ada.Containers.Vectors (Element_Type => Service,
                                 Index_Type   => Natural);

   procedure Print (P : in Service_Vector.Cursor);
   procedure Print (P : in Service);
   procedure Set_Member (P     : in out Service;
                         Field : in Service_Fields;
                         Value : in Util.Beans.Objects.Object);
   function Get_Member (P     : in Service;
                        Field : in Service_Fields) return Util.Beans.Objects.Object;

   procedure Set_Member (P     : in out Service;
                         Field : in Service_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      Ada.Text_IO.Put_Line ("Set member " & Service_Fields'Image (Field)
                            & " to " & Util.Beans.Objects.To_String (Value));
      case Field is
         when FIELD_PRIORITY =>
            P.Priority := Util.Beans.Objects.To_Integer (Value);

         when FIELD_TYPE =>
            P.RDS_Type := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_URI =>
            P.URI := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCAL_ID =>
            P.Local_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_DELEGATE =>
            P.Delegate := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   function Get_Member (P : in Service;
                        Field : in Service_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_PRIORITY =>
            return Util.Beans.Objects.To_Object (P.Priority);

         when FIELD_TYPE =>
            return Util.Beans.Objects.To_Object (P.RDS_Type);

         when FIELD_URI =>
            return Util.Beans.Objects.To_Object (P.URI);

         when FIELD_LOCAL_ID =>
            return Util.Beans.Objects.To_Object (P.Local_Id);

         when FIELD_DELEGATE =>
            return Util.Beans.Objects.To_Object (P.Delegate);

      end case;
   end Get_Member;

   package Service_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Service,
                                               Element_Type_Access => Service_Access,
                                               Fields              => Service_Fields,
                                               Set_Member          => Set_Member);

   package Service_Vector_Mapper is
     new Util.Serialize.Mappers.Vector_Mapper (Vectors        => Service_Vector,
                                               Element_Mapper => Service_Mapper);

   procedure Print (P : in Service) is
   begin
      Ada.Text_IO.Put_Line ("        URI: " & To_String (P.URI));
      Ada.Text_IO.Put_Line ("   Priority: " & Integer'Image (P.Priority));
      Ada.Text_IO.Put_Line ("Type (last): " & To_String (P.RDS_Type));
      Ada.Text_IO.Put_Line ("   Delegate: " & To_String (P.Delegate));
      Ada.Text_IO.New_Line;
   end Print;

   procedure Print (P : in Service_Vector.Cursor) is
   begin
      Print (Service_Vector.Element (P));
   end Print;

   Service_Mapping        : aliased Service_Mapper.Mapper;
   Service_Vector_Mapping : aliased Service_Vector_Mapper.Mapper;
   Mapper                 : Util.Serialize.Mappers.Processing;
begin
   Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmlrd file...");
      return;
   end if;

   Service_Mapping.Add_Mapping ("Type", FIELD_TYPE);
   Service_Mapping.Add_Mapping ("URI", FIELD_URI);
   Service_Mapping.Add_Mapping ("Delegate", FIELD_DELEGATE);
   Service_Mapping.Add_Mapping ("@priority", FIELD_PRIORITY);
   Service_Mapping.Bind (Get_Member'Access);
   Service_Vector_Mapping.Set_Mapping (Service_Mapping'Unchecked_Access);

   Mapper.Add_Mapping ("XRDS/XRD/Service", Service_Vector_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);

         List : aliased Service_Vector_Mapper.Vector;
      begin
         Service_Vector_Mapper.Set_Context (Mapper, List'Unchecked_Access);
         Reader.Parse (S, Mapper);

         Ada.Text_IO.Put_Line ("Rule count: " & Count_Type'Image (List.Length));

         --  The list now contains our elements.
         List.Iterate (Process => Print'Access);

         declare

            Output : Util.Serialize.IO.XML.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Output.Start_Entity ("XRDS");
            Service_Vector_Mapping.Write (Output, List);
            Output.End_Entity ("XRDS");
            Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;
      end;
   end loop;
end Xmlrd;

Update example

Update example