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

with MAT.Memory.Readers;
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;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  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;

   --  ------------------------------
   --  Find from the memory map the memory slots whose address intersects
   --  the region [From .. To] and 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;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  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
                  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;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (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 (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;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            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
         Old_Slot : Allocation;
         Pos      : Allocation_Cursor;

         procedure Update_Size (Key : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

      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;
         if Addr /= 0 then
            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;

      --  ------------------------------
      --  Find from the memory map the memory slots whose address intersects
      --  the region [From .. To] and 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;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

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

with MAT.Memory.Readers;
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;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  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;

   --  ------------------------------
   --  Find from the memory map the memory slots whose address intersects
   --  the region [From .. To] and 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;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  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
                  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;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (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 (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;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            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
            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;
         if Addr /= 0 then
            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;

      --  ------------------------------
      --  Find from the memory map the memory slots whose address intersects
      --  the region [From .. To] and 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;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  mat-events-probes -- Event probes
--  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 Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Finalization;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   subtype Probe_Event_Type is MAT.Events.Targets.Probe_Event_Type;

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Probe_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in out Probe_Event_Type) is abstract;

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Targets.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Targets.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Probe_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

-----------------------------------------------------------------------
--  mat-events-probes -- Event probes
--  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 Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Finalization;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   subtype Probe_Event_Type is MAT.Events.Targets.Probe_Event_Type;

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Probe_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in out Probe_Event_Type) is abstract;

   --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
   --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
   --  to the <tt>Id</tt> event.
   procedure Update_Event (Probe   : in Probe_Type;
                           Id      : in MAT.Events.Targets.Event_Id_Type;
                           Size    : in MAT.Types.Target_Size;
                           Prev_Id : in MAT.Events.Targets.Event_Id_Type);

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Targets.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Targets.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Probe_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

Declare the Update_Event procedure

Declare the Update_Event procedure


-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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 Ada.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

--  == Session ==
--  The <tt>ADO.Sessions</tt> package defines the control and management of database sessions.
--  The database session is represented by the <tt>Session</tt> or <tt>Master_Session</tt> types.
--
--  @include ado-sessions-factory.ads
--
package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;
--
--     type Session_Proxy is limited record
--        Counter : Util.Concurrent.Counters.Counter;
--        Session : Session_Record_Access;
--        Factory : Object_Factory_Access;
--     end record;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access all ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "");
   pragma Inline (Check_Session);

end ADO.Sessions;

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

with Ada.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

--  == Session ==
--  The <tt>ADO.Sessions</tt> package defines the control and management of database sessions.
--  The database session is represented by the <tt>Session</tt> or <tt>Master_Session</tt> types.
--  It provides operation to create a database statement that can be executed.
--  The <tt>Session</tt> type is used to represent read-only database sessions.  It provides
--  operations to query the database but it does not allow to update or delete content.
--  The <tt>Master_Session</tt> type extends the <tt>Session</tt> type to provide write
--  access and it provides operations to get update or delete statements.  The differentiation
--  between the two sessions is provided for the support of database replications with
--  databases such as MySQL.
--
--  @include ado-sessions-factory.ads
--
package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access all ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "");
   pragma Inline (Check_Session);

end ADO.Sessions;

Add some documentation

Add some documentation


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

with Util.Test_Caller;

package body Util.Events.Timers.Tests is

   use Util.Tests;
   use type Ada.Real_Time.Time;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Is_Scheduled",
                       Test_Empty_Timer'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Process",
                       Test_Timer_Event'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Repeat",
                       Test_Repeat_Timer'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Repeat+Process",
                       Test_Many_Timers'Access);
   end Add_Tests;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class) is
   begin
      Sub.Count := Sub.Count + 1;
      if Sub.Repeat > 1 then
         Sub.Repeat := Sub.Repeat - 1;
         Event.Repeat (Ada.Real_Time.Milliseconds (1));
      end if;
   end Time_Handler;

   --  -----------------------
   --  Test empty timers.
   --  -----------------------
   procedure Test_Empty_Timer (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Deadline : Ada.Real_Time.Time;
   begin
      T.Assert (not R.Is_Scheduled, "Empty timer should not be scheduled");
      T.Assert (R.Time_Of_Event = Ada.Real_Time.Time_Last, "Time_Of_Event returned invalid value");
      R.Cancel;
      M.Process (Deadline);
      T.Assert (Deadline = Ada.Real_Time.Time_Last,
                "The Process operation returned invalid deadline");
   end Test_Empty_Timer;

   procedure Test_Timer_Event (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      Now      : Ada.Real_Time.Time;
   begin
      for Retry in 1 .. 10 loop
         M.Set_Timer (T'Unchecked_Access, R, Start + Ada.Real_Time.Milliseconds (10));
         M.Process (Deadline);
         Now := Ada.Real_Time.Clock;
         exit when Now < Deadline;
      end loop;
      T.Assert (Now < Deadline, "The timer deadline is not correct");
      delay until Deadline;
      M.Process (Deadline);
      Assert_Equals (T, 1, T.Count, "The timer handler was not called");
   end Test_Timer_Event;

   --  -----------------------
   --  Test repeating timers.
   --  -----------------------
   procedure Test_Repeat_Timer (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      Now      : Ada.Real_Time.Time;
   begin
      T.Count := 0;
      T.Repeat := 5;
      for Retry in 1 .. 10 loop
         M.Set_Timer (T'Unchecked_Access, R, Start + Ada.Real_Time.Milliseconds (10));
         M.Process (Deadline);
         Now := Ada.Real_Time.Clock;
         exit when Now < Deadline;
      end loop;
      T.Assert (Now < Deadline, "The timer deadline is not correct");
      loop
         delay until Deadline;
         M.Process (Deadline);
         exit when Deadline >= Now + Ada.Real_Time.Seconds (1);
      end loop;
      Assert_Equals (T, 5, T.Count, "The timer handler was not repeated");
   end Test_Repeat_Timer;

   --  -----------------------
   --  Test executing several timers.
   --  -----------------------
   procedure Test_Many_Timers (T : in out Test) is
      Timer_Count : constant Positive := 30;

      type Timer_Ref_Array is array (1 .. Timer_Count) of Timer_Ref;
      type Test_Ref_Array is array (1 .. Timer_Count) of aliased Test;

      M        : Timer_List;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      R        : Timer_Ref_Array;
      D        : Test_Ref_Array;
      Dt       : Ada.Real_Time.Time_Span;
      Count    : Natural := 0;
   begin
      for I in R'Range loop
         D (I).Count := 0;
         D (I).Repeat := 4;
         if I mod 2 = 0 then
            Dt := Ada.Real_Time.Milliseconds (40);
         else
            Dt := Ada.Real_Time.Milliseconds (20);
         end if;
         M.Set_Timer (D (I)'Unchecked_Access, R (I), Start + Dt);
      end loop;
      loop
         M.Process (Deadline);
         exit when Deadline >= Start + Ada.Real_Time.Seconds (10);
         Count := Count + 1;
         delay until Deadline;
      end loop;
      Util.Tests.Assert_Equals (T, 4, Count, "Count of Process");
      for I in D'Range loop
         Util.Tests.Assert_Equals (T, 4, D (I).Count, "Invalid count for timer at "
                                     & Natural'Image (I) & " " & Natural'Image (Count));
      end loop;
   end Test_Many_Timers;

end Util.Events.Timers.Tests;

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

with Util.Test_Caller;

package body Util.Events.Timers.Tests is

   use Util.Tests;
   use type Ada.Real_Time.Time;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Is_Scheduled",
                       Test_Empty_Timer'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Process",
                       Test_Timer_Event'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Repeat",
                       Test_Repeat_Timer'Access);
      Caller.Add_Test (Suite, "Test Util.Events.Timers.Repeat+Process",
                       Test_Many_Timers'Access);
   end Add_Tests;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class) is
   begin
      Sub.Count := Sub.Count + 1;
      if Sub.Repeat > 1 then
         Sub.Repeat := Sub.Repeat - 1;
         Event.Repeat (Ada.Real_Time.Milliseconds (1));
      end if;
   end Time_Handler;

   --  -----------------------
   --  Test empty timers.
   --  -----------------------
   procedure Test_Empty_Timer (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Deadline : Ada.Real_Time.Time;
   begin
      T.Assert (not R.Is_Scheduled, "Empty timer should not be scheduled");
      T.Assert (R.Time_Of_Event = Ada.Real_Time.Time_Last, "Time_Of_Event returned invalid value");
      R.Cancel;
      M.Process (Deadline);
      T.Assert (Deadline = Ada.Real_Time.Time_Last,
                "The Process operation returned invalid deadline");
   end Test_Empty_Timer;

   procedure Test_Timer_Event (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      Now      : Ada.Real_Time.Time;
   begin
      for Retry in 1 .. 10 loop
         M.Set_Timer (T'Unchecked_Access, R, Start + Ada.Real_Time.Milliseconds (10));
         M.Process (Deadline);
         Now := Ada.Real_Time.Clock;
         exit when Now < Deadline;
      end loop;
      T.Assert (Now < Deadline, "The timer deadline is not correct");
      delay until Deadline;
      M.Process (Deadline);
      Assert_Equals (T, 1, T.Count, "The timer handler was not called");
   end Test_Timer_Event;

   --  -----------------------
   --  Test repeating timers.
   --  -----------------------
   procedure Test_Repeat_Timer (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      Now      : Ada.Real_Time.Time;
   begin
      T.Count := 0;
      T.Repeat := 5;
      for Retry in 1 .. 10 loop
         M.Set_Timer (T'Unchecked_Access, R, Start + Ada.Real_Time.Milliseconds (10));
         M.Process (Deadline);
         Now := Ada.Real_Time.Clock;
         exit when Now < Deadline;
      end loop;
      T.Assert (Now < Deadline, "The timer deadline is not correct");
      loop
         delay until Deadline;
         M.Process (Deadline);
         exit when Deadline >= Now + Ada.Real_Time.Seconds (1);
      end loop;
      Assert_Equals (T, 5, T.Count, "The timer handler was not repeated");
   end Test_Repeat_Timer;

   --  -----------------------
   --  Test executing several timers.
   --  -----------------------
   procedure Test_Many_Timers (T : in out Test) is
      Timer_Count : constant Positive := 30;

      type Timer_Ref_Array is array (1 .. Timer_Count) of Timer_Ref;
      type Test_Ref_Array is array (1 .. Timer_Count) of aliased Test;

      M        : Timer_List;
      Start    : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      R        : Timer_Ref_Array;
      D        : Test_Ref_Array;
      Dt       : Ada.Real_Time.Time_Span;
      Count    : Natural := 0;
   begin
      for I in R'Range loop
         D (I).Count := 0;
         D (I).Repeat := 4;
         if I mod 2 = 0 then
            Dt := Ada.Real_Time.Milliseconds (40);
         else
            Dt := Ada.Real_Time.Milliseconds (20);
         end if;
         M.Set_Timer (D (I)'Unchecked_Access, R (I), Start + Dt);
      end loop;
      loop
         M.Process (Deadline);
         exit when Deadline >= Start + Ada.Real_Time.Seconds (10);
         Count := Count + 1;
         delay until Deadline;
      end loop;
      Util.Tests.Assert_Equals (T, 8, Count, "Count of Process");
      for I in D'Range loop
         Util.Tests.Assert_Equals (T, 4, D (I).Count, "Invalid count for timer at "
                                     & Natural'Image (I) & " " & Natural'Image (Count));
      end loop;
   end Test_Many_Timers;

end Util.Events.Timers.Tests;

Fix the timer unit test

Fix the timer unit test


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

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

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

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

Add F_FILE_NAME, F_FUNCTION_NAME and F_LINE_NUMBER


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

   use Util.Tests;
   use ASF.Converters.Dates;

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

   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String);

   procedure Test_Conversion_Error (T          : in out Test;
                                    Value      : in String);

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Short)",
                       Test_Date_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Medium)",
                       Test_Date_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Long)",
                       Test_Date_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Full)",
                       Test_Date_Full_Converter'Access);

      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Short)",
                       Test_Time_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Medium)",
                       Test_Time_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Long)",
                       Test_Time_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_Object (Error)",
                       Test_Date_Converter_Error'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Dates.Date_Converter'Class,
                                        Name   => ASF.Converters.Dates.Date_Converter_Access);

      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
      D     : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19,
                                                                             3, 4, 5);
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      if Date_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.TIME,
                                                          Locale  => "en",
                                                          Pattern => "");
      elsif Time_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.DATE,
                                                          Locale  => "en",
                                                          Pattern => "");
      else
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.BOTH,
                                                          Locale  => "en",
                                                          Pattern => "");
      end if;
      UI.Set_Converter (C.all'Access);
      declare
         use type Ada.Calendar.Time;

         R : constant String := C.To_String (Ctx, UI, Util.Beans.Objects.Time.To_Object (D));
         V : Util.Beans.Objects.Object;
         S : Util.Dates.Date_Record;
      begin
         Util.Tests.Assert_Equals (T, Expect, R, "Invalid date conversion");

         V := C.To_Object (Ctx, UI, R);
         Util.Dates.Split (Into => S, Date => Util.Beans.Objects.Time.To_Time (V));

         if Date_Style /= Dates.DEFAULT then
            T.Assert (Util.Dates.Is_Same_Day (Util.Beans.Objects.Time.To_Time (V), D),
                      "Invalid date");
         else
            Util.Tests.Assert_Equals (T, 3, Natural (S.Hour),
                                      "Invalid date conversion: hour");
            Util.Tests.Assert_Equals (T, 4, Natural (S.Minute),
                                      "Invalid date conversion: minute");
            if Time_Style = Dates.LONG then
               Util.Tests.Assert_Equals (T, 5, Natural (S.Second),
                                         "Invalid date conversion: second");
            end if;
         end if;

      exception
         when others =>
            T.Fail ("Exception when converting date string: " & R);

      end;
      Free (C);
   end Test_Date_Conversion;

   --  ------------------------------
   --  Test the date short converter.
   --  ------------------------------
   procedure Test_Date_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.SHORT, ASF.Converters.Dates.DEFAULT,
                            "19/11/2011");
   end Test_Date_Short_Converter;

   --  ------------------------------
   --  Test the date medium converter.
   --  ------------------------------
   procedure Test_Date_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.MEDIUM, ASF.Converters.Dates.DEFAULT,
                            "Nov 19, 2011");
   end Test_Date_Medium_Converter;

   --  ------------------------------
   --  Test the date long converter.
   --  ------------------------------
   procedure Test_Date_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.LONG, ASF.Converters.Dates.DEFAULT,
                            "November 19, 2011");
   end Test_Date_Long_Converter;

   --  ------------------------------
   --  Test the date full converter.
   --  ------------------------------
   procedure Test_Date_Full_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.FULL, ASF.Converters.Dates.DEFAULT,
                            "Saturday, November 19, 2011");
   end Test_Date_Full_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.SHORT,
                            "03:04");
   end Test_Time_Short_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.MEDIUM,
                            "03:04");
   end Test_Time_Medium_Converter;

   --  ------------------------------
   --  Test the time long converter.
   --  ------------------------------
   procedure Test_Time_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.LONG,
                            "03:04:05");
   end Test_Time_Long_Converter;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Conversion_Error (T          : in out Test;
                                    Value      : in String) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Dates.Date_Converter'Class,
                                        Name   => ASF.Converters.Dates.Date_Converter_Access);

      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      C := ASF.Converters.Dates.Create_Date_Converter (Date    => ASF.Converters.Dates.LONG,
                                                       Time    => ASF.Converters.Dates.LONG,
                                                       Format  => ASF.Converters.Dates.BOTH,
                                                       Locale  => "en",
                                                       Pattern => "");
      UI.Set_Converter (C.all'Access);
      declare
         V : Util.Beans.Objects.Object;
         pragma Unreferenced (V);
      begin
         V := C.To_Object (Ctx, UI, Value);
         T.Fail ("No exception raised for " & Value);

      exception
         when Invalid_Conversion =>
            null;

      end;
      Free (C);
   end Test_Conversion_Error;

   --  ------------------------------
   --  Test converter reporting conversion errors when converting a string back to a date.
   --  ------------------------------
   procedure Test_Date_Converter_Error (T : in out Test) is
   begin
      Test_Conversion_Error (T, "some invalid date");
   end Test_Date_Converter_Error;

end ASF.Converters.Tests;

-----------------------------------------------------------------------
--  Faces Context Tests - Unit tests for ASF.Contexts.Faces
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 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.Calendar;
with Ada.Calendar.Formatting;
with Ada.Unchecked_Deallocation;
with Util.Beans.Objects.Time;
with Util.Test_Caller;
with Util.Dates;
with ASF.Tests;
with ASF.Components.Html.Text;
with ASF.Converters.Dates;
with ASF.Converters.Numbers;
package body ASF.Converters.Tests is

   use Util.Tests;
   use ASF.Converters.Dates;

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

   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String);

   procedure Test_Conversion_Error (T          : in out Test;
                                    Value      : in String);

   procedure Test_Number_Conversion (T       : in out Test;
                                     Picture : in String;
                                     Value   : in Float;
                                     Expect  : in String);

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Short)",
                       Test_Date_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Medium)",
                       Test_Date_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Long)",
                       Test_Date_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Full)",
                       Test_Date_Full_Converter'Access);

      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Short)",
                       Test_Time_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Medium)",
                       Test_Time_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Long)",
                       Test_Time_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_Object (Error)",
                       Test_Date_Converter_Error'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Numbers.To_String (Float)",
                       Test_Number_Converter'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Dates.Date_Converter'Class,
                                        Name   => ASF.Converters.Dates.Date_Converter_Access);

      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
      D     : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19,
                                                                             3, 4, 5);
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      if Date_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.TIME,
                                                          Locale  => "en",
                                                          Pattern => "");
      elsif Time_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.DATE,
                                                          Locale  => "en",
                                                          Pattern => "");
      else
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.BOTH,
                                                          Locale  => "en",
                                                          Pattern => "");
      end if;
      UI.Set_Converter (C.all'Access);
      declare
         use type Ada.Calendar.Time;

         R : constant String := C.To_String (Ctx, UI, Util.Beans.Objects.Time.To_Object (D));
         V : Util.Beans.Objects.Object;
         S : Util.Dates.Date_Record;
      begin
         Util.Tests.Assert_Equals (T, Expect, R, "Invalid date conversion");

         V := C.To_Object (Ctx, UI, R);
         Util.Dates.Split (Into => S, Date => Util.Beans.Objects.Time.To_Time (V));

         if Date_Style /= Dates.DEFAULT then
            T.Assert (Util.Dates.Is_Same_Day (Util.Beans.Objects.Time.To_Time (V), D),
                      "Invalid date");
         else
            Util.Tests.Assert_Equals (T, 3, Natural (S.Hour),
                                      "Invalid date conversion: hour");
            Util.Tests.Assert_Equals (T, 4, Natural (S.Minute),
                                      "Invalid date conversion: minute");
            if Time_Style = Dates.LONG then
               Util.Tests.Assert_Equals (T, 5, Natural (S.Second),
                                         "Invalid date conversion: second");
            end if;
         end if;

      exception
         when others =>
            T.Fail ("Exception when converting date string: " & R);

      end;
      Free (C);
   end Test_Date_Conversion;

   --  ------------------------------
   --  Test the date short converter.
   --  ------------------------------
   procedure Test_Date_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.SHORT, ASF.Converters.Dates.DEFAULT,
                            "19/11/2011");
   end Test_Date_Short_Converter;

   --  ------------------------------
   --  Test the date medium converter.
   --  ------------------------------
   procedure Test_Date_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.MEDIUM, ASF.Converters.Dates.DEFAULT,
                            "Nov 19, 2011");
   end Test_Date_Medium_Converter;

   --  ------------------------------
   --  Test the date long converter.
   --  ------------------------------
   procedure Test_Date_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.LONG, ASF.Converters.Dates.DEFAULT,
                            "November 19, 2011");
   end Test_Date_Long_Converter;

   --  ------------------------------
   --  Test the date full converter.
   --  ------------------------------
   procedure Test_Date_Full_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.FULL, ASF.Converters.Dates.DEFAULT,
                            "Saturday, November 19, 2011");
   end Test_Date_Full_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.SHORT,
                            "03:04");
   end Test_Time_Short_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.MEDIUM,
                            "03:04");
   end Test_Time_Medium_Converter;

   --  ------------------------------
   --  Test the time long converter.
   --  ------------------------------
   procedure Test_Time_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.LONG,
                            "03:04:05");
   end Test_Time_Long_Converter;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Conversion_Error (T          : in out Test;
                                    Value      : in String) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Dates.Date_Converter'Class,
                                        Name   => ASF.Converters.Dates.Date_Converter_Access);

      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      C := ASF.Converters.Dates.Create_Date_Converter (Date    => ASF.Converters.Dates.LONG,
                                                       Time    => ASF.Converters.Dates.LONG,
                                                       Format  => ASF.Converters.Dates.BOTH,
                                                       Locale  => "en",
                                                       Pattern => "");
      UI.Set_Converter (C.all'Access);
      declare
         V : Util.Beans.Objects.Object;
         pragma Unreferenced (V);
      begin
         V := C.To_Object (Ctx, UI, Value);
         T.Fail ("No exception raised for " & Value);

      exception
         when Invalid_Conversion =>
            null;

      end;
      Free (C);
   end Test_Conversion_Error;

   --  ------------------------------
   --  Test converter reporting conversion errors when converting a string back to a date.
   --  ------------------------------
   procedure Test_Date_Converter_Error (T : in out Test) is
   begin
      Test_Conversion_Error (T, "some invalid date");
   end Test_Date_Converter_Error;

   --  Test number converter.
   procedure Test_Number_Conversion (T       : in out Test;
                                     Picture : in String;
                                     Value   : in Float;
                                     Expect  : in String) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Numbers.Number_Converter'Class,
                                        Name   => ASF.Converters.Numbers.Number_Converter_Access);

      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Numbers.Number_Converter_Access;
      D     : Util.Beans.Objects.Object := Util.Beans.Objects.To_Object (Value);
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      C := new ASF.Converters.Numbers.Number_Converter;
      UI.Set_Converter (C.all'Access);
      C.Set_Picture (Picture);
      declare
         use type Ada.Calendar.Time;

         R : constant String := C.To_String (Ctx, UI, D);
      begin
         Util.Tests.Assert_Equals (T, Expect, R,
                                   "Invalid number conversion with picture " & Picture);
      end;
      Free (C);

   end Test_Number_Conversion;

   --  ------------------------------
   --  Test converter reporting conversion errors when converting a string back to a date.
   --  ------------------------------
   procedure Test_Number_Converter (T : in out Test) is
   begin
      Test_Number_Conversion (T, "Z9.99", 12.345323, "12.35");
      Test_Number_Conversion (T, "Z9.99", 2.334323, " 2.33");
      Test_Number_Conversion (T, "<$Z_ZZ9.99>", 2.334323, " €    2.33 ");
      Test_Number_Conversion (T, "Z_ZZ9.99B$", 2.334323, "    2.33 €");
      Test_Number_Conversion (T, "Z_ZZ9.99B$", 2342.334323, "2,342.33 €");
      Test_Number_Conversion (T, "Z_ZZ9.99B$", 21342.334323, "2,342.33 €");
   end Test_Number_Converter;

end ASF.Converters.Tests;

Add Test_Number_Converter and register the new test