-----------------------------------------------------------------------
--  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;
            Freed_Slots.Insert (Addr, Item);
         end if;
      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 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;

Fix Probe_Free that could raise a key already in map exception


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      Assert (T, Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      Assert (T, False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         Assert (T, Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      Assert (T, Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      Assert (T, not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               Assert (T, Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                       & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      Assert (T, Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            Assert (T, Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      Assert (T, Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               Assert (T, Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                       & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

Fix compilation with GNAT 2011

Fix compilation with GNAT 2011


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  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.Log.Loggers;

with Ada.IO_Exceptions;
with ADO.Queries.Loaders;
package body ADO.Drivers is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Drivers");

   --  Global configuration properties (loaded by Initialize).
   Global_Config : Util.Properties.Manager;

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      Log.Info ("Initialize using property file {0}", Config);

      begin
         Util.Properties.Load_Properties (Global_Config, Config);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Configuration file '{0}' does not exist", Config);
      end;

      Initialize (Global_Config);
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      Global_Config := Util.Properties.Manager (Config);

      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Global_Config.Get ("ado.queries.paths", ".;db"),
                                      Global_Config.Get ("ado.queries.load", "false") = "true");
      ADO.Drivers.Initialize;
   end Initialize;

   --  ------------------------------
   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Name    : in String;
                        Default : in String := "") return String is
   begin
      return Global_Config.Get (Name, Default);
   end Get_Config;

   --  Initialize the drivers which are available.
   procedure Initialize is separate;

end ADO.Drivers;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  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.Log.Loggers;

with Ada.IO_Exceptions;

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

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Drivers");

   --  Global configuration properties (loaded by Initialize).
   Global_Config : Util.Properties.Manager;

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      Log.Info ("Initialize using property file {0}", Config);

      begin
         Util.Properties.Load_Properties (Global_Config, Config);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Configuration file '{0}' does not exist", Config);
      end;

      Initialize (Global_Config);
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      Global_Config := Util.Properties.Manager (Config);

      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Global_Config.Get ("ado.queries.paths", ".;db"),
                                      Global_Config.Get ("ado.queries.load", "false") = "true");

      --  Initialize the drivers.
      ADO.Drivers.Initialize;
   end Initialize;

   --  ------------------------------
   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Name    : in String;
                        Default : in String := "") return String is
   begin
      return Global_Config.Get (Name, Default);
   end Get_Config;

   --  Initialize the drivers which are available.
   procedure Initialize is separate;

end ADO.Drivers;

Add some comments

Add some comments


-----------------------------------------------------------------------
--  druss-commands-wifi -- Wifi related commands
--  Copyright (C) 2017, 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 Ada.Strings.Unbounded;
with Bbox.API;
package body Druss.Commands.Wifi is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Enable or disable with wifi radio.
   --  ------------------------------
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      procedure Radio (Gateway : in out Druss.Gateways.Gateway_Type;
                       State   : in String);

      procedure Radio (Gateway : in out Druss.Gateways.Gateway_Type;
                       State   : in String) is
         Box     : Bbox.API.Client_Type;
      begin
         Box.Set_Server (To_String (Gateway.Ip));
         if Ada.Strings.Unbounded.Length (Gateway.Passwd) > 0 then
            Box.Login (To_String (Gateway.Passwd));
         end if;
         Box.Put ("wireless", (if State = "on" then "radio.enable=1" else "radio.enable=0"));
      end Radio;

   begin
      Druss.Commands.Gateway_Command (Command, Args, 1, Radio'Access, Context);
   end Do_Enable;

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Wifi_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Wifi_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Print_On_Off (Console, F_BOOL, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         Console.Print_Field (F_CHANNEL, Gateway.Wifi.Get ("wireless.radio.24.current_channel", " "));
         Console.Print_Field (F_SSID, Gateway.Wifi.Get ("wireless.ssid.24.id", " "));
         Console.Print_Field (F_PROTOCOL, Gateway.Wifi.Get ("wireless.ssid.24.security.protocol", " "));
         Console.Print_Field (F_ENCRYPTION, Gateway.Wifi.Get ("wireless.ssid.24.security.encryption", " "));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Console.End_Row;

         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            return;
         end if;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, To_String (Gateway.Ip));
         Print_On_Off (Console, F_BOOL, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         Console.Print_Field (F_CHANNEL, Gateway.Wifi.Get ("wireless.radio.5.current_channel", " "));
         Console.Print_Field (F_SSID, Gateway.Wifi.Get ("wireless.ssid.5.id", " "));
         Console.Print_Field (F_PROTOCOL, Gateway.Wifi.Get ("wireless.ssid.5.security.protocol", " "));
         Console.Print_Field (F_ENCRYPTION, Gateway.Wifi.Get ("wireless.ssid.5.security.encryption", " "));
         Console.End_Row;
      end Wifi_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "Bbox IP", 15);
      Console.Print_Title (F_BOOL, "Enable", 8);
      Console.Print_Title (F_CHANNEL, "Channel", 8);
      Console.Print_Title (F_SSID, "SSID", 20);
      Console.Print_Title (F_PROTOCOL, "Protocol", 12);
      Console.Print_Title (F_ENCRYPTION, "Encryption", 12);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Wifi_Status'Access);
   end Do_Status;

   --  ------------------------------
   --  Execute a command to control or get status about the Wifi.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count = 0 then
         Command.Do_Status (Args, Context);
      elsif Args.Get_Argument (1) in "on" | "off" then
         Command.Do_Enable (Args, Context);
      elsif Args.Get_Argument (1) = "show" then
         Command.Do_Status (Args, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid sub-command: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "wifi: Control and get status about the Bbox Wifi");
      Console.Notice (N_HELP, "Usage: wifi {<action>} [<parameters>]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  wifi on [IP]...    Turn ON the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi off [IP]...   Turn OFF the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi show          Show information about the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi devices       Show the wifi devices which are connected.");
   end Help;

end Druss.Commands.Wifi;

-----------------------------------------------------------------------
--  druss-commands-wifi -- Wifi related commands
--  Copyright (C) 2017, 2018, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Bbox.API;
package body Druss.Commands.Wifi is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Enable or disable with wifi radio.
   --  ------------------------------
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      procedure Radio (Gateway : in out Druss.Gateways.Gateway_Type;
                       State   : in String);

      procedure Radio (Gateway : in out Druss.Gateways.Gateway_Type;
                       State   : in String) is
         Box     : Bbox.API.Client_Type;
      begin
         Box.Set_Server (To_String (Gateway.Ip));
         if Ada.Strings.Unbounded.Length (Gateway.Passwd) > 0 then
            Box.Login (To_String (Gateway.Passwd));
         end if;
         Box.Put ("wireless", (if State = "on" then "radio.enable=1" else "radio.enable=0"));
      end Radio;

   begin
      Druss.Commands.Gateway_Command (Command, Args, 1, Radio'Access, Context);
   end Do_Enable;

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Wifi_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Wifi_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Print_On_Off (Console, F_BOOL, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         Console.Print_Field (F_CHANNEL, Gateway.Wifi.Get ("wireless.radio.24.current_channel", " "));
         Console.Print_Field (F_SSID, Gateway.Wifi.Get ("wireless.ssid.24.id", " "));
         Console.Print_Field (F_PROTOCOL, Gateway.Wifi.Get ("wireless.ssid.24.security.protocol", " "));
         Console.Print_Field (F_ENCRYPTION, Gateway.Wifi.Get ("wireless.ssid.24.security.encryption", " "));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Console.End_Row;

         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            return;
         end if;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, To_String (Gateway.Ip));
         Print_On_Off (Console, F_BOOL, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         Console.Print_Field (F_CHANNEL, Gateway.Wifi.Get ("wireless.radio.5.current_channel", " "));
         Console.Print_Field (F_SSID, Gateway.Wifi.Get ("wireless.ssid.5.id", " "));
         Console.Print_Field (F_PROTOCOL, Gateway.Wifi.Get ("wireless.ssid.5.security.protocol", " "));
         Console.Print_Field (F_ENCRYPTION, Gateway.Wifi.Get ("wireless.ssid.5.security.encryption", " "));
         Console.End_Row;
      end Wifi_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "Bbox IP", 15);
      Console.Print_Title (F_BOOL, "Enable", 8);
      Console.Print_Title (F_CHANNEL, "Channel", 8);
      Console.Print_Title (F_SSID, "SSID", 20);
      Console.Print_Title (F_PROTOCOL, "Protocol", 12);
      Console.Print_Title (F_ENCRYPTION, "Encryption", 12);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Wifi_Status'Access);
   end Do_Status;

   --  ------------------------------
   --  Execute a command to control or get status about the Wifi.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count = 0 then
         Command.Do_Status (Args, Context);
      elsif Args.Get_Argument (1) in "on" | "off" then
         Command.Do_Enable (Args, Context);
      elsif Args.Get_Argument (1) = "show" then
         Command.Do_Status (Args, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid sub-command: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args, Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "wifi: Control and get status about the Bbox Wifi");
      Console.Notice (N_HELP, "Usage: wifi {<action>} [<parameters>]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  wifi on [IP]...    Turn ON the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi off [IP]...   Turn OFF the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi show          Show information about the wifi on the Bbox.");
      Console.Notice (N_HELP, "  wifi devices       Show the wifi devices which are connected.");
   end Help;

end Druss.Commands.Wifi;

Change Help command to accept in out command


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "52";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "53";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

Bump version

Bump version


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "66";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "67";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

bump synth version

bump synth version

Unfortunately, I already published v1.67 so another release is needed.


-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 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 Interfaces;

with Ada.IO_Exceptions;
with Ada.Directories;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers;
   use Interfaces;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Base_Time : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year  => 1970,
                                                                   Month => 1,
                                                                   Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Unsigned_32 := 60;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Query_List  : Query_Definition_Access := null;

   --  Convert a Time to an Unsigned_32.
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32;
   pragma Inline_Always (To_Unsigned_32);

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (Query : in Query_Definition_Access) return Unsigned_32;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Query.File   := File;
      Query.Next   := File.Queries;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         File.Next := Query_Files;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant ADO.Drivers.Driver_Access := ADO.Drivers.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Convert a Time to an Unsigned_32.
   --  ------------------------------
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32 is
      D : constant Duration := Duration (T - Base_Time);
   begin
      return Unsigned_32 (D);
   end To_Unsigned_32;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (Query : in Query_Definition_Access) return Unsigned_32 is
   begin
      return To_Unsigned_32 (Ada.Directories.Modification_Time (Query.File.Path.all));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Query.File.Path.all);
         return 0;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (Query : in Query_Definition_Access) return Boolean is
      Now : constant Unsigned_32 := To_Unsigned_32 (Ada.Calendar.Clock);
   begin
      --  Have we passed the next check time?
      if Query.File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      Query.File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Unsigned_32 := Modification_Time (Query);
      begin
         if Query.File.Last_Modified = M then
            return False;
         end if;
         Query.File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Into : in Query_File_Access) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is record
         File       : Query_File_Access;
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Access;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (Into.File.all, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            if Into.Query_Def /= null then
               Into.Query := new Query_Info;
               Into.Query_Def.Query := Into.Query;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if Into.Query /= null and Into.Driver >= 0 then
               Set_Query_Pattern (Into.Query.Main_Query (ADO.Drivers.Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if Into.Query /= null and Into.Driver >= 0 then
               Set_Query_Pattern (Into.Query.Count_Query (ADO.Drivers.Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
   begin
      Log.Info ("Reading XML query {0}", Into.Path.all);
      Loader.File   := Into;
      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Reader.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Reader, Loader'Access);

      --  Read the XML query file.
      Reader.Parse (Into.Path.all);

      Into.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Into.Path.all);

   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Into : in Query_Definition_Access) is
   begin
      if Into.Query = null or else Is_Modified (Into)  then
         Read_Query (Into.File);
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Paths : in String;
                         Load  : in Boolean) is
      File : Query_File_Access := Query_Files;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Path.all,
                                                                 Paths => Paths);
         begin
            File.Path := new String '(Path);
            if Load then
               Read_Query (File);
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body Query is
   begin
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 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 Interfaces;

with Ada.IO_Exceptions;
with Ada.Directories;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers;
   use Interfaces;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Base_Time : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year  => 1970,
                                                                   Month => 1,
                                                                   Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Unsigned_32 := 60;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Query_List  : Query_Definition_Access := null;

   --  Convert a Time to an Unsigned_32.
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32;
   pragma Inline_Always (To_Unsigned_32);

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (Query : in Query_Definition_Access) return Unsigned_32;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Query.File   := File;
      Query.Next   := File.Queries;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         File.Next := Query_Files;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant ADO.Drivers.Driver_Access := ADO.Drivers.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Convert a Time to an Unsigned_32.
   --  ------------------------------
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32 is
      D : constant Duration := Duration (T - Base_Time);
   begin
      return Unsigned_32 (D);
   end To_Unsigned_32;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (Query : in Query_Definition_Access) return Unsigned_32 is
   begin
      return To_Unsigned_32 (Ada.Directories.Modification_Time (Query.File.Path.all));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Query.File.Path.all);
         return 0;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (Query : in Query_Definition_Access) return Boolean is
      Now : constant Unsigned_32 := To_Unsigned_32 (Ada.Calendar.Clock);
   begin
      --  Have we passed the next check time?
      if Query.File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      Query.File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Unsigned_32 := Modification_Time (Query);
      begin
         if Query.File.Last_Modified = M then
            return False;
         end if;
         Query.File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Into : in Query_File_Access) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is record
         File       : Query_File_Access;
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Access;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (Into.File.all, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            Into.Query := null;
            if Into.Query_Def /= null then
               Into.Query := new Query_Info;
               Into.Query_Def.Query := Into.Query;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if Into.Query /= null and Into.Driver >= 0 then
               Set_Query_Pattern (Into.Query.Main_Query (ADO.Drivers.Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if Into.Query /= null and Into.Driver >= 0 then
               Set_Query_Pattern (Into.Query.Count_Query (ADO.Drivers.Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
   begin
      Log.Info ("Reading XML query {0}", Into.Path.all);
      Loader.File   := Into;
      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Reader.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Reader, Loader'Access);

      --  Read the XML query file.
      Reader.Parse (Into.Path.all);

      Into.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Into.Path.all);

   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Into : in Query_Definition_Access) is
   begin
      if Into.Query = null or else Is_Modified (Into)  then
         Read_Query (Into.File);
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Paths : in String;
                         Load  : in Boolean) is
      File : Query_File_Access := Query_Files;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Path.all,
                                                                 Paths => Paths);
         begin
            File.Path := new String '(Path);
            if Load then
               Read_Query (File);
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body Query is
   begin
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

Clear the reference to the query info when a new query is found