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

with Util.Beans.Basic;
with Util.Beans.Objects.Lists;
with Util.Beans.Lists.Strings;
with Util.Strings.Vectors;

with ADO;
with ADO.Utils;
with ADO.Schemas;
with ADO.Sessions;

with AWA.Tags.Models;
with AWA.Tags.Modules;

--  == Tag Beans ==
--  Several bean types are provided to represent and manage a list of tags.
--
--  === Tag_List_Bean ===
--  The <tt>Tag_List_Bean</tt> holds a list of tags and provides operations used by the
--  <tt>awa:tagList</tt> component to add or remove tags within a <tt>h:form</tt> component.
--  A bean can be declared and configured as follows in the XML application configuration file:
--
--    <managed-bean>
--      <managed-bean-name>questionTags</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_List_Bean</managed-bean-class>
--      <managed-bean-scope>Request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>Awa_Question</value>
--      </managed-property>
--      <managed-property>
--        <property-name>permission</property-name>
--        <property-class>String</property-class>
--        <value>question-edit</value>
--      </managed-property>
--    </managed-bean>
--
--  The <tt>entity_type</tt> property defines the name of the database table to which the tags
--  are assigned.  The <tt>permission</tt> property defines the permission name that must be used
--  to verify that the user has the permission do add or remove the tag.  Such permission is
--  verified only when the <tt>awa:tagList</tt> component is used within a form.
--
--  === Tag_Search_Bean ===
--  The <tt>Tag_Search_Bean</tt> is dedicated to searching for tags that start with a given
--  pattern.  The auto complete feature of the <tt>awa:tagList</tt> component can use this
--  bean type to look in the database for tags matching a start pattern.  The declaration of the
--  bean should define the database table to search for tags associated with a given database
--  table.  This is done in the XML configuration with the <tt>entity_type</tt> property.
--
--    <managed-bean>
--      <managed-bean-name>questionTagSearch</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_Search_Bean</managed-bean-class>
--      <managed-bean-scope>Request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_question</value>
--      </managed-property>
--    </managed-bean>
--
--  === Tag_Info_List_Bean ===
--  The <tt>Tag_Info_List_Bean</tt> holds a collection of tags with their weight.  It is used
--  by the <tt>awa:tagCloud</tt> component.
--
--
--    <managed-bean>
--      <managed-bean-name>QuestionTagList</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_Info_List_Bean</managed-bean-class>
--      <managed-bean-scope>Request</managed-bean-scope>
--      <managed-property>
--        <property-name>Entity_Type</property-name>
--        <property-class>String</property-class>
--        <value>Awa_Question</value>
--      </managed-property>
--    </managed-bean>
package AWA.Tags.Beans is

   --  Compare two tags on their count and name.
   function "<" (Left, Right : in AWA.Tags.Models.Tag_Info) return Boolean;

   package Tag_Ordered_Sets is
     new Ada.Containers.Ordered_Sets (Element_Type => AWA.Tags.Models.Tag_Info,
                                      "="          => AWA.Tags.Models."=");

   type Tag_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with private;

   type Tag_List_Bean_Access is access all Tag_List_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Set the entity type (database table) onto which the tags are associated.
   procedure Set_Entity_Type (Into  : in out Tag_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access);

   --  Set the permission to check before removing or adding a tag on the entity.
   procedure Set_Permission (Into       : in out Tag_List_Bean;
                             Permission : in String);

   --  Load the tags associated with the given database identifier.
   procedure Load_Tags (Into          : in out Tag_List_Bean;
                        Session       : in ADO.Sessions.Session;
                        For_Entity_Id : in ADO.Identifier);

   --  Set the list of tags to add.
   procedure Set_Added (Into  : in out Tag_List_Bean;
                        Tags  : in Util.Strings.Vectors.Vector);

   --  Set the list of tags to remove.
   procedure Set_Deleted (Into : in out Tag_List_Bean;
                          Tags : in Util.Strings.Vectors.Vector);

   --  Update the tags associated with the tag entity represented by <tt>For_Entity_Id</tt>.
   --  The list of tags defined by <tt>Set_Deleted</tt> are removed first and the list of
   --  tags defined by <tt>Set_Added</tt> are associated with the database entity.
   procedure Update_Tags (From          : in Tag_List_Bean;
                          For_Entity_Id : in ADO.Identifier);

   --  Create the tag list bean instance.
   function Create_Tag_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Tag_Search_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with private;
   type Tag_Search_Bean_Access is access all Tag_Search_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_Search_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Search the tags that match the search string.
   procedure Search_Tags (Into    : in out Tag_Search_Bean;
                          Session : in ADO.Sessions.Session;
                          Search  : in String);

   --  Set the entity type (database table) onto which the tags are associated.
   procedure Set_Entity_Type (Into  : in out Tag_Search_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access);

   --  Create the tag search bean instance.
   function Create_Tag_Search_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

   type Tag_Info_List_Bean is
     new AWA.Tags.Models.Tag_Info_List_Bean and Util.Beans.Basic.Bean with private;
   type Tag_Info_List_Bean_Access is access all Tag_Info_List_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_Info_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of tags.
   procedure Load_Tags (Into    : in out Tag_Info_List_Bean;
                        Session : in out ADO.Sessions.Session);

   --  Create the tag info list bean instance.
   function Create_Tag_Info_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access;

   --  The <tt>Entity_Tag_Map</tt> contains a list of tags associated with some entities.
   --  It allows to retrieve from the database all the tags associated with several entities
   --  and get the list of tags for a given entity.
   type Entity_Tag_Map is new Ada.Finalization.Limited_Controlled with private;

   --  Get the list of tags associated with the given entity.
   --  Returns null if the entity does not have any tag.
   function Get_Tags (From       : in Entity_Tag_Map;
                      For_Entity : in ADO.Identifier)
                      return Util.Beans.Lists.Strings.List_Bean_Access;

   --  Get the list of tags associated with the given entity.
   --  Returns a null object if the entity does not have any tag.
   function Get_Tags (From       : in Entity_Tag_Map;
                      For_Entity : in ADO.Identifier)
                      return Util.Beans.Objects.Object;

   --  Release the list of tags.
   procedure Clear (List : in out Entity_Tag_Map);

   --  Load the list of tags associated with a list of entities.
   procedure Load_Tags (Into        : in out Entity_Tag_Map;
                        Session     : in out ADO.Sessions.Session'Class;
                        Entity_Type : in String;
                        List        : in ADO.Utils.Identifier_Vector);

   --  Release the list of tags.
   overriding
   procedure Finalize (List : in out Entity_Tag_Map);

private

   type Tag_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
      Permission  : Ada.Strings.Unbounded.Unbounded_String;
      Current     : Natural := 0;
      Added       : Util.Strings.Vectors.Vector;
      Deleted     : Util.Strings.Vectors.Vector;
   end record;

   type Tag_Search_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Tag_Info_List_Bean is
     new AWA.Tags.Models.Tag_Info_List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   package Entity_Tag_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => ADO.Identifier,
                                     Element_Type    => Util.Beans.Lists.Strings.List_Bean_Access,
                                     Hash            => ADO.Utils.Hash,
                                     Equivalent_Keys => ADO."=",
                                     "="             => Util.Beans.Lists.Strings."=");

   type Entity_Tag_Map is new Ada.Finalization.Limited_Controlled with record
      Tags : Entity_Tag_Maps.Map;
   end record;

end AWA.Tags.Beans;

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

with Util.Beans.Basic;
with Util.Beans.Objects.Lists;
with Util.Beans.Lists.Strings;
with Util.Strings.Vectors;

with ADO;
with ADO.Utils;
with ADO.Schemas;
with ADO.Sessions;

with AWA.Tags.Models;
with AWA.Tags.Modules;

--  == Tag Beans ==
--  Several bean types are provided to represent and manage a list of tags.
--
--  === Tag_List_Bean ===
--  The <tt>Tag_List_Bean</tt> holds a list of tags and provides operations used by the
--  <tt>awa:tagList</tt> component to add or remove tags within a <tt>h:form</tt> component.
--  A bean can be declared and configured as follows in the XML application configuration file:
--
--    <managed-bean>
--      <managed-bean-name>questionTags</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_List_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>Awa_Question</value>
--      </managed-property>
--      <managed-property>
--        <property-name>permission</property-name>
--        <property-class>String</property-class>
--        <value>question-edit</value>
--      </managed-property>
--    </managed-bean>
--
--  The <tt>entity_type</tt> property defines the name of the database table to which the tags
--  are assigned.  The <tt>permission</tt> property defines the permission name that must be used
--  to verify that the user has the permission do add or remove the tag.  Such permission is
--  verified only when the <tt>awa:tagList</tt> component is used within a form.
--
--  === Tag_Search_Bean ===
--  The <tt>Tag_Search_Bean</tt> is dedicated to searching for tags that start with a given
--  pattern.  The auto complete feature of the <tt>awa:tagList</tt> component can use this
--  bean type to look in the database for tags matching a start pattern.  The declaration of the
--  bean should define the database table to search for tags associated with a given database
--  table.  This is done in the XML configuration with the <tt>entity_type</tt> property.
--
--    <managed-bean>
--      <managed-bean-name>questionTagSearch</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_Search_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_question</value>
--      </managed-property>
--    </managed-bean>
--
--  === Tag_Info_List_Bean ===
--  The <tt>Tag_Info_List_Bean</tt> holds a collection of tags with their weight.  It is used
--  by the <tt>awa:tagCloud</tt> component.
--
--    <managed-bean>
--      <managed-bean-name>questionTagList</managed-bean-name>
--      <managed-bean-class>AWA.Tags.Beans.Tag_Info_List_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_question</value>
--      </managed-property>
--    </managed-bean>
--
package AWA.Tags.Beans is

   --  Compare two tags on their count and name.
   function "<" (Left, Right : in AWA.Tags.Models.Tag_Info) return Boolean;

   package Tag_Ordered_Sets is
     new Ada.Containers.Ordered_Sets (Element_Type => AWA.Tags.Models.Tag_Info,
                                      "="          => AWA.Tags.Models."=");

   type Tag_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with private;

   type Tag_List_Bean_Access is access all Tag_List_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Set the entity type (database table) onto which the tags are associated.
   procedure Set_Entity_Type (Into  : in out Tag_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access);

   --  Set the permission to check before removing or adding a tag on the entity.
   procedure Set_Permission (Into       : in out Tag_List_Bean;
                             Permission : in String);

   --  Load the tags associated with the given database identifier.
   procedure Load_Tags (Into          : in out Tag_List_Bean;
                        Session       : in ADO.Sessions.Session;
                        For_Entity_Id : in ADO.Identifier);

   --  Set the list of tags to add.
   procedure Set_Added (Into  : in out Tag_List_Bean;
                        Tags  : in Util.Strings.Vectors.Vector);

   --  Set the list of tags to remove.
   procedure Set_Deleted (Into : in out Tag_List_Bean;
                          Tags : in Util.Strings.Vectors.Vector);

   --  Update the tags associated with the tag entity represented by <tt>For_Entity_Id</tt>.
   --  The list of tags defined by <tt>Set_Deleted</tt> are removed first and the list of
   --  tags defined by <tt>Set_Added</tt> are associated with the database entity.
   procedure Update_Tags (From          : in Tag_List_Bean;
                          For_Entity_Id : in ADO.Identifier);

   --  Create the tag list bean instance.
   function Create_Tag_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Tag_Search_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with private;
   type Tag_Search_Bean_Access is access all Tag_Search_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_Search_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Search the tags that match the search string.
   procedure Search_Tags (Into    : in out Tag_Search_Bean;
                          Session : in ADO.Sessions.Session;
                          Search  : in String);

   --  Set the entity type (database table) onto which the tags are associated.
   procedure Set_Entity_Type (Into  : in out Tag_Search_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access);

   --  Create the tag search bean instance.
   function Create_Tag_Search_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

   type Tag_Info_List_Bean is
     new AWA.Tags.Models.Tag_Info_List_Bean and Util.Beans.Basic.Bean with private;
   type Tag_Info_List_Bean_Access is access all Tag_Info_List_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Tag_Info_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of tags.
   procedure Load_Tags (Into    : in out Tag_Info_List_Bean;
                        Session : in out ADO.Sessions.Session);

   --  Create the tag info list bean instance.
   function Create_Tag_Info_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access;

   --  The <tt>Entity_Tag_Map</tt> contains a list of tags associated with some entities.
   --  It allows to retrieve from the database all the tags associated with several entities
   --  and get the list of tags for a given entity.
   type Entity_Tag_Map is new Ada.Finalization.Limited_Controlled with private;

   --  Get the list of tags associated with the given entity.
   --  Returns null if the entity does not have any tag.
   function Get_Tags (From       : in Entity_Tag_Map;
                      For_Entity : in ADO.Identifier)
                      return Util.Beans.Lists.Strings.List_Bean_Access;

   --  Get the list of tags associated with the given entity.
   --  Returns a null object if the entity does not have any tag.
   function Get_Tags (From       : in Entity_Tag_Map;
                      For_Entity : in ADO.Identifier)
                      return Util.Beans.Objects.Object;

   --  Release the list of tags.
   procedure Clear (List : in out Entity_Tag_Map);

   --  Load the list of tags associated with a list of entities.
   procedure Load_Tags (Into        : in out Entity_Tag_Map;
                        Session     : in out ADO.Sessions.Session'Class;
                        Entity_Type : in String;
                        List        : in ADO.Utils.Identifier_Vector);

   --  Release the list of tags.
   overriding
   procedure Finalize (List : in out Entity_Tag_Map);

private

   type Tag_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
      Permission  : Ada.Strings.Unbounded.Unbounded_String;
      Current     : Natural := 0;
      Added       : Util.Strings.Vectors.Vector;
      Deleted     : Util.Strings.Vectors.Vector;
   end record;

   type Tag_Search_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Tag_Info_List_Bean is
     new AWA.Tags.Models.Tag_Info_List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Tags.Modules.Tag_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   package Entity_Tag_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => ADO.Identifier,
                                     Element_Type    => Util.Beans.Lists.Strings.List_Bean_Access,
                                     Hash            => ADO.Utils.Hash,
                                     Equivalent_Keys => ADO."=",
                                     "="             => Util.Beans.Lists.Strings."=");

   type Entity_Tag_Map is new Ada.Finalization.Limited_Controlled with record
      Tags : Entity_Tag_Maps.Map;
   end record;

end AWA.Tags.Beans;

Document the tag beans

Document the tag beans


-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural;
      Total_Alloc   : MAT.Types.Target_Size;
      Total_Free    : MAT.Types.Target_Size;
      Malloc_Count  : Natural;
      Free_Count    : Natural;
      Realloc_Count : Natural;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

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

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

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

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

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

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

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

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

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

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

private

   protected type Memory_Allocator is

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

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

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

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

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

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

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

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

      --  Get the global memory and allocation statistics.
      procedure Stat_Information (Result : out Memory_Stat);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Stats         : Memory_Stat;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural := 0;
      Total_Alloc   : MAT.Types.Target_Size := 0;
      Total_Free    : MAT.Types.Target_Size := 0;
      Malloc_Count  : Natural := 0;
      Free_Count    : Natural := 0;
      Realloc_Count : Natural := 0;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

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

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

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

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

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

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

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

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

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

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

private

   protected type Memory_Allocator is

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

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

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

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

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

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

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

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

      --  Get the global memory and allocation statistics.
      procedure Stat_Information (Result : out Memory_Stat);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Stats         : Memory_Stat;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Add initializer in the Memory_Stat type

Add initializer in the Memory_Stat type


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

with MAT.Readers.Marshaller;
package body MAT.Events.Probes is

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

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

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

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

   --  ------------------------------
   --  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.Event_Id_Type;
                           Size    : in MAT.Types.Target_Size;
                           Prev_Id : in MAT.Events.Event_Id_Type) is
   begin
      Probe.Owner.Get_Target_Events.Update_Event (Id, Size, Prev_Id);
   end Update_Event;

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
   end Initialize;

   --  ------------------------------
   --  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.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
      Probe.Owner := Into'Unchecked_Access;
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Tick_Ref;

      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Types.Target_Thread_Ref
                    (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind));

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop --  reverse Count .. 1 loop
                     if Count < Frame.Depth then
                        Frame.Frame (Count - I + 1) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      --  Convert the time in usec to make computation easier.
      Client.Event.Time := MAT.Types.Target_Tick_Ref (Time_Sec) * 1_000_000;
      Client.Event.Time := Client.Event.Time + MAT.Types.Target_Tick_Ref (Time_Usec);
      Frame.Cur_Depth := Count;

   exception
      when E : others =>
         Log.Error ("Marshaling error, frame count {0}", Natural'Image (Count));
         raise;

   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Prev_Id := 0;
            Client.Event.Old_Size := 0;
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            Client.Frames.Insert (Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                                  Result => Client.Event.Frame);
            Client.Events.Insert (Client.Event);
            Handler.Probe.Execute (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  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_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  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) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

      --  Look at the probe definition to gather the target address size.
      Client.Addr_Size := MAT.Events.T_UINT32;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            if Def.Ref = P_THREAD_SP or Def.Ref = P_FRAME_PC then
               Client.Addr_Size := Def.Kind;
               exit;
            end if;
         end;
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

   --  ------------------------------
   --  Get the size of a target address (4 or 8 bytes).
   --  ------------------------------
   function Get_Address_Size (Client : in Probe_Manager_Type) return MAT.Events.Attribute_Type is
   begin
      return Client.Addr_Size;
   end Get_Address_Size;

end MAT.Events.Probes;

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

with MAT.Readers.Marshaller;
package body MAT.Events.Probes is

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

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

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

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

   --  ------------------------------
   --  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.Event_Id_Type;
                           Size    : in MAT.Types.Target_Size;
                           Prev_Id : in MAT.Events.Event_Id_Type) is
   begin
      Probe.Owner.Get_Target_Events.Update_Event (Id, Size, Prev_Id);
   end Update_Event;

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
      Manager.Frames := new MAT.Frames.Targets.Target_Frames;
   end Initialize;

   --  ------------------------------
   --  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.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
      Probe.Owner := Into'Unchecked_Access;
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   --  ------------------------------
   --  Get the target frames.
   --  ------------------------------
   function Get_Target_Frames (Client : in Probe_Manager_Type)
                               return MAT.Frames.Targets.Target_Frames_Access is
   begin
      return Client.Frames;
   end Get_Target_Frames;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Tick_Ref;

      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Types.Target_Thread_Ref
                    (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind));

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop --  reverse Count .. 1 loop
                     if Count < Frame.Depth then
                        Frame.Frame (Count - I + 1) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      --  Convert the time in usec to make computation easier.
      Client.Event.Time := MAT.Types.Target_Tick_Ref (Time_Sec) * 1_000_000;
      Client.Event.Time := Client.Event.Time + MAT.Types.Target_Tick_Ref (Time_Usec);
      Frame.Cur_Depth := Count;

   exception
      when E : others =>
         Log.Error ("Marshaling error, frame count {0}", Natural'Image (Count));
         raise;

   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Prev_Id := 0;
            Client.Event.Old_Size := 0;
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            Client.Frames.Insert (Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                                  Result => Client.Event.Frame);
            Client.Events.Insert (Client.Event);
            Handler.Probe.Execute (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  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_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  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) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

      --  Look at the probe definition to gather the target address size.
      Client.Addr_Size := MAT.Events.T_UINT32;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            if Def.Ref = P_THREAD_SP or Def.Ref = P_FRAME_PC then
               Client.Addr_Size := Def.Kind;
               exit;
            end if;
         end;
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

   --  ------------------------------
   --  Get the size of a target address (4 or 8 bytes).
   --  ------------------------------
   function Get_Address_Size (Client : in Probe_Manager_Type) return MAT.Events.Attribute_Type is
   begin
      return Client.Addr_Size;
   end Get_Address_Size;

end MAT.Events.Probes;

Implement Get_Target_Frames to retrieve the allocated target frames Allocate the target frames when the probe manager is created but do not release it when the probe manager is destroyed because the target process instance needs it


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

with GNAT.Command_Line;

with Ada.Directories;
with Ada.Text_IO;
package body Gen.Commands.Generate is

   use GNAT.Command_Line;
   use Ada.Directories;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      File_Count   : Natural := 0;
   begin
      Generator.Read_Project ("dynamo.xml", True);
      Gen.Generator.Read_Mappings (Generator);

      --  Parse the command line for the --package option.
      loop
         case Getopt ("p: ? -package:") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-package" then
               Generator.Enable_Package_Generation (Parameter);
            end if;

         when 'p' =>
            Generator.Enable_Package_Generation (Parameter);

         when others =>
            null;
         end case;
      end loop;

      --  Read the model files.
      loop
         declare
            Model_File : constant String := Get_Argument;
         begin
            exit when Model_File'Length = 0;
            File_Count := File_Count + 1;
            if Ada.Directories.Exists (Model_File)
              and then Ada.Directories.Kind (Model_File) = Ada.Directories.Directory then
               Gen.Generator.Read_Models (Generator, Model_File);
            else
               Gen.Generator.Read_Model (Generator, Model_File, False);
            end if;
         end;
      end loop;

      if File_Count = 0 then
         Gen.Generator.Read_Models (Generator, "db");
      end if;

      --  Run the generation.
      Gen.Generator.Prepare (Generator);
      Gen.Generator.Generate_All (Generator);
      Gen.Generator.Finish (Generator);
      Generator.Save_Project;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("generate: Generate the Ada files for the database model or queries");
      Put_Line ("Usage: generate [--package NAME] [MODEL ...]");
      New_Line;
      Put_Line ("  Read the XML/XMI model description (Hibernate mapping, query mapping, ...)");
      Put_Line ("  and generate the Ada model files that correspond to the mapping.");
      Put_Line ("  The --package option allows to generate only the package with the given name.");
      Put_Line ("  The default is to generate all the packages that are recognized.");
   end Help;

end Gen.Commands.Generate;

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

with GNAT.Command_Line;

with Ada.Directories;
with Ada.Text_IO;
package body Gen.Commands.Generate is

   use GNAT.Command_Line;
   use Ada.Directories;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      File_Count   : Natural := 0;
   begin
      Generator.Read_Project ("dynamo.xml", True);
      Gen.Generator.Read_Mappings (Generator);

      --  Parse the command line for the --package option.
      loop
         case Getopt ("p: ? -package:") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-package" then
               Generator.Enable_Package_Generation (Parameter);
            end if;

         when 'p' =>
            Generator.Enable_Package_Generation (Parameter);

         when others =>
            null;
         end case;
      end loop;

      --  Read the model files.
      loop
         declare
            Model_File : constant String := Get_Argument;
         begin
            exit when Model_File'Length = 0;
            File_Count := File_Count + 1;
            if Ada.Directories.Exists (Model_File)
              and then Ada.Directories.Kind (Model_File) = Ada.Directories.Directory
            then
               Gen.Generator.Read_Models (Generator, Model_File);
            else
               Gen.Generator.Read_Model (Generator, Model_File, False);
            end if;
         end;
      end loop;

      if File_Count = 0 then
         Gen.Generator.Read_Models (Generator, "db");
      end if;

      --  Run the generation.
      Gen.Generator.Prepare (Generator);
      Gen.Generator.Generate_All (Generator);
      Gen.Generator.Finish (Generator);
      Generator.Save_Project;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("generate: Generate the Ada files for the database model or queries");
      Put_Line ("Usage: generate [--package NAME] [MODEL ...]");
      New_Line;
      Put_Line ("  Read the XML/XMI model description (Hibernate mapping, query mapping, ...)");
      Put_Line ("  and generate the Ada model files that correspond to the mapping.");
      Put_Line ("  The --package option allows to generate only the package with the given name.");
      Put_Line ("  The default is to generate all the packages that are recognized.");
   end Help;

end Gen.Commands.Generate;

Fix compilation warnings

Fix compilation warnings


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

with Util.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Sessions.Factory");

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Sessions.Generate_Id (Rand);

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access
        := new Session_Record '(Ada.Finalization.Limited_Controlled with
                                Ref_Counter  => Util.Concurrent.Counters.ONE,
                                Create_Time  => Ada.Calendar.Clock,
                                Max_Inactive => Factory.Max_Inactive,
                                others       => <>);
   begin
      Impl.Access_Time := Impl.Create_Time;
      Sess.Impl        := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Sessions.Insert (Sess);

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      null;
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Factory.Sessions.Find (Id);

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Factory.Sessions.Initialize;
   end Initialize;

   protected body Session_Cache is

      --  ------------------------------
      --  Find the session in the session cache.
      --  ------------------------------
      function Find (Id : in String) return Session is
         Pos : constant Session_Maps.Cursor := Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            return Session_Maps.Element (Pos);
         else
            return Null_Session;
         end if;
      end Find;

      --  ------------------------------
      --  Insert the session in the session cache.
      --  ------------------------------
      procedure Insert (Sess : in Session) is
      begin
         Sessions.Insert (Sess.Impl.Id.all'Access, Sess);
      end Insert;

      --  ------------------------------
      --  Generate a random bitstream.
      --  ------------------------------
      procedure Generate_Id (Rand : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;
         use Interfaces;

         Size : constant Stream_Element_Offset := Rand'Length / 4;
      begin
         --  Generate the random sequence.
         for I in 0 .. Size - 1 loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Random);
            begin
               Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
               Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate_Id;

      --  ------------------------------
      --  Initialize the random generator.
      --  ------------------------------
      procedure Initialize is
      begin
         Id_Random.Reset (Random);
      end Initialize;

   end Session_Cache;

end ASF.Sessions.Factory;

-----------------------------------------------------------------------
--  asf.sessions.factory -- ASF Sessions factory
--  Copyright (C) 2010, 2011, 2012, 2014, 2015, 2016 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.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Sessions.Factory");

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Sessions.Generate_Id (Rand);

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access
        := new Session_Record '(Ada.Finalization.Limited_Controlled with
                                Ref_Counter  => Util.Concurrent.Counters.ONE,
                                Create_Time  => Ada.Calendar.Clock,
                                Max_Inactive => Factory.Max_Inactive,
                                others       => <>);
   begin
      Impl.Access_Time := Impl.Create_Time;
      Sess.Impl        := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Sessions.Insert (Sess);

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      Factory.Sessions.Delete (Sess);
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Factory.Sessions.Find (Id);

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Factory.Sessions.Initialize;
   end Initialize;

   protected body Session_Cache is

      --  ------------------------------
      --  Find the session in the session cache.
      --  ------------------------------
      function Find (Id : in String) return Session is
         Pos : constant Session_Maps.Cursor := Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            return Session_Maps.Element (Pos);
         else
            return Null_Session;
         end if;
      end Find;

      --  ------------------------------
      --  Insert the session in the session cache.
      --  ------------------------------
      procedure Insert (Sess : in Session) is
      begin
         Sessions.Insert (Sess.Impl.Id.all'Access, Sess);
      end Insert;

      --  ------------------------------
      --  Remove the session from the session cache.
      --  ------------------------------
      procedure Delete (Sess : in out Session) is
         Pos : Session_Maps.Cursor := Sessions.Find (Sess.Impl.Id.all'Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            Session_Maps.Delete (Sessions, Pos);
         end if;
         Finalize (Sess);
      end Delete;

      --  ------------------------------
      --  Generate a random bitstream.
      --  ------------------------------
      procedure Generate_Id (Rand : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;
         use Interfaces;

         Size : constant Stream_Element_Offset := Rand'Length / 4;
      begin
         --  Generate the random sequence.
         for I in 0 .. Size - 1 loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Random);
            begin
               Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
               Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate_Id;

      --  ------------------------------
      --  Initialize the random generator.
      --  ------------------------------
      procedure Initialize is
      begin
         Id_Random.Reset (Random);
      end Initialize;

   end Session_Cache;

end ASF.Sessions.Factory;

Implement the Delete protected procedure and update Delete_Session to use it