-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  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.
-----------------------------------------------------------------------

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the start and finish time for the events that have been received.
   --  ------------------------------
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time) is
   begin
      Target.Events.Get_Time_Range (Start, Finish);
   end Get_Time_Range;

   --  ------------------------------
   --  Get the probe event with the given allocated unique id.
   --  ------------------------------
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type is
   begin
      return Target.Events.Get_Event (Id);
   end Get_Event;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_Event_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id + 1, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Events (Current.Count).Id := Last_Id;
         Last_Id := Last_Id + 1;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

      --  ------------------------------
      --  Get the start and finish time for the events that have been received.
      --  ------------------------------
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time) is
         First : constant Event_Block_Access := Events.First_Element;
         Last  : constant Event_Block_Access := Events.Last_Element;
      begin
         Start  := First.Events (First.Events'First).Time;
         Finish := Last.Events (Last.Count).Time;
      end Get_Time_Range;

      --  ------------------------------
      --  Get the probe event with the given allocated unique id.
      --  ------------------------------
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type is
         Iter  : Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id;
            if Pos < Block.Count then
               return Block.Events (Pos);
            end if;
            Event_Id_Maps.Next (Iter);
         end loop;
         raise Not_Found;
      end Get_Event;

   end Event_Collector;

end MAT.Events.Targets;

-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  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.
-----------------------------------------------------------------------

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the start and finish time for the events that have been received.
   --  ------------------------------
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time) is
   begin
      Target.Events.Get_Time_Range (Start, Finish);
   end Get_Time_Range;

   --  ------------------------------
   --  Get the probe event with the given allocated unique id.
   --  ------------------------------
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type is
   begin
      return Target.Events.Get_Event (Id);
   end Get_Event;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_Event_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id + 1, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Events (Current.Count).Id := Last_Id;
         Last_Id := Last_Id + 1;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

      --  ------------------------------
      --  Get the start and finish time for the events that have been received.
      --  ------------------------------
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time) is
         First : constant Event_Block_Access := Events.First_Element;
         Last  : constant Event_Block_Access := Events.Last_Element;
      begin
         Start  := First.Events (First.Events'First).Time;
         Finish := Last.Events (Last.Count).Time;
      end Get_Time_Range;

      --  ------------------------------
      --  Get the probe event with the given allocated unique id.
      --  ------------------------------
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type is
         Iter  : Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id;
            if Pos < Block.Count then
               return Block.Events (Pos);
            end if;
            Event_Id_Maps.Next (Iter);
         end loop;
         raise Not_Found;
      end Get_Event;

      --  ------------------------------
      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      --  ------------------------------
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type)) is
         Iter  : Event_Id_Cursor := Ids.Floor (Start);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
         Id    : Event_Id_Type := Start;
      begin
         --  First, find the block and position of the first event.
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id;
            if Pos < Block.Count then

               --  Second, iterate over the events moving to the next event block
               --  until we reach the last event.
               loop
                  Process (Block.Events (Pos));
                  exit when Id > Finish;
                  Pos := Pos + 1;
                  Id := Id + 1;
                  if Pos = Block.Count then
                     Event_Id_Maps.Next (Iter);
                     exit when not Event_Id_Maps.Has_Element (Iter);
                     Block := Event_Id_Maps.Element (Iter);
                     Pos := Block.Events'First;
                  end if;
               end loop;
            end if;
            Event_Id_Maps.Next (Iter);
         end loop;
      end Iterate;

   end Event_Collector;

end MAT.Events.Targets;

Implement the protected procedure Iterate


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

with ASF.Parts;
with ASF.Parts.Upload_Method;
with ASF.Events.Faces.Actions;

package body AWA.Storages.Beans.Factories is

   package Upload_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Upload_Bean,
                                                      Method => Upload,
                                                      Name   => "upload");

   package Save_Part_Binding is
     new ASF.Parts.Upload_Method.Bind (Name   => "save",
                                       Bean   => Upload_Bean,
                                       Method => Save_Part);

   Upload_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Upload_Binding.Proxy'Access,
         2 => Save_Part_Binding.Proxy'Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Upload_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Upload_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Upload_Bean bean instance.
   --  ------------------------------
   function Create_Upload_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Upload_Bean_Access := new Upload_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Upload_Bean;

   package Folder_Save_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Folder_Bean,
                                                      Method => Save,
                                                      Name   => "save");

   Folder_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Folder_Save_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Folder_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Storages.Models.Storage_Folder_Ref (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Folder_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Folder_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Folder_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Upload_Bean bean instance.
   --  ------------------------------
   function Create_Folder_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Folder_Bean_Access := new Folder_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Folder_Bean;

end AWA.Storages.Beans.Factories;

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

with ASF.Parts;
with ASF.Parts.Upload_Method;
with ASF.Events.Faces.Actions;

package body AWA.Storages.Beans.Factories is

   package Upload_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Upload_Bean,
                                                      Method => Upload,
                                                      Name   => "upload");

   package Delete_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Upload_Bean,
                                                      Method => Delete,
                                                      Name   => "delete");

   package Save_Part_Binding is
     new ASF.Parts.Upload_Method.Bind (Name   => "save",
                                       Bean   => Upload_Bean,
                                       Method => Save_Part);

   Upload_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Upload_Binding.Proxy'Access,
         2 => Save_Part_Binding.Proxy'Access,
         3 => Delete_Binding.Proxy'Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Upload_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Upload_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Upload_Bean bean instance.
   --  ------------------------------
   function Create_Upload_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Upload_Bean_Access := new Upload_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Upload_Bean;

   package Folder_Save_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Folder_Bean,
                                                      Method => Save,
                                                      Name   => "save");

   Folder_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Folder_Save_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Folder_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Storages.Models.Storage_Folder_Ref (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Folder_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Folder_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Folder_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Upload_Bean bean instance.
   --  ------------------------------
   function Create_Folder_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Folder_Bean_Access := new Folder_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Folder_Bean;

end AWA.Storages.Beans.Factories;

Define the delete action on the Ada bean


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

--  The <b>ASF.Views.Nodes.Core</b> package defines some pre-defined
--  core tag nodes which are mapped in the following namespaces:
--
--    xmlns:c="http://java.sun.com/jstl/core"
--    xmlns:ui="http://java.sun.com/jsf/facelets"
--    xmlns:fn="http://java.sun.com/jsp/jstl/functions"
--
--  The following JSTL core elements are defined:
--    <c:set var="name" value="#{expr}"/>
--    <c:if test="#{expr}"> ...</c:if>
--    <c:choose><c:when test="#{expr}"></c:when><c:otherwise/</c:choose>
--
--
with ASF.Factory;
with EL.Functions;
package ASF.Views.Nodes.Core is

   FN_URI : constant String := "http://java.sun.com/jsp/jstl/functions";

   --  Tag factory for nodes defined in this package.
   function Definition return ASF.Factory.Factory_Bindings_Access;

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://java.sun.com/jsp/jstl/functions"
   --  Functions:
   --    capitalize, toUpperCase, toLowerCase
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   --  ------------------------------
   --  Set Tag
   --  ------------------------------
   --  The <c:set var="name" value="#{expr}"/> variable creation.
   --  The variable is created in the faces context.
   type Set_Tag_Node is new Tag_Node with private;
   type Set_Tag_Node_Access is access all Set_Tag_Node'Class;

   --  Create the Set Tag
   function Create_Set_Tag_Node (Binding    : in Binding_Access;
                                 Line       : in Line_Info;
                                 Parent     : in Tag_Node_Access;
                                 Attributes : in Tag_Attribute_Array_Access)
                                 return Tag_Node_Access;

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access Set_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  ------------------------------
   --  If Tag
   --  ------------------------------
   --  The <c:if test="#{expr}"> ...</c:if> condition.
   --  If the condition evaluates to true when the component tree is built,
   --  the children of this node are evaluated.  Otherwise the entire
   --  sub-tree is not present in the component tree.
   type If_Tag_Node is new Tag_Node with private;
   type If_Tag_Node_Access is access all If_Tag_Node'Class;

   --  Create the If Tag
   function Create_If_Tag_Node (Binding    : in Binding_Access;
                                Line       : in Line_Info;
                                Parent     : in Tag_Node_Access;
                                Attributes : in Tag_Attribute_Array_Access)
                                return Tag_Node_Access;

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access If_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  ------------------------------
   --  Choose Tag
   --  ------------------------------
   --  The <c:choose> ...</c:choose> choice.
   --  Evaluate a set of choices (<c:when>) until one of them is found.
   --  When no choice is found, evaluate the <c:otherwise> node.
   type Choose_Tag_Node is new Tag_Node with private;
   type Choose_Tag_Node_Access is access all Choose_Tag_Node'Class;

   --  Freeze the tag node tree and perform any initialization steps
   --  necessary to build the components efficiently.
   --  Prepare the evaluation of choices by identifying the <c:when> and
   --  <c:otherwise> conditions.
   overriding
   procedure Freeze (Node : access Choose_Tag_Node);

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access Choose_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  Create the <c:choose> tag node
   function Create_Choose_Tag_Node (Binding    : in Binding_Access;
                                    Line       : in Line_Info;
                                    Parent     : in Tag_Node_Access;
                                    Attributes : in Tag_Attribute_Array_Access)
                                   return Tag_Node_Access;

   --  ------------------------------
   --  When Tag
   --  ------------------------------
   --  The <c:when test="#{expr}"> ...</c:when> choice.
   --  If the condition evaluates to true when the component tree is built,
   --  the children of this node are evaluated.  Otherwise the entire
   --  sub-tree is not present in the component tree.
   type When_Tag_Node is new If_Tag_Node with private;
   type When_Tag_Node_Access is access all When_Tag_Node'Class;

   --  Check whether the node condition is selected.
   function Is_Selected (Node    : When_Tag_Node;
                         Context : Facelet_Context'Class) return Boolean;

   --  Create the When Tag
   function Create_When_Tag_Node (Binding    : in Binding_Access;
                                  Line       : in Line_Info;
                                  Parent     : in Tag_Node_Access;
                                  Attributes : in Tag_Attribute_Array_Access)
                                 return Tag_Node_Access;

   --  ------------------------------
   --  Otherwise Tag
   --  ------------------------------
   --  The <c:otherwise> ...</c:otherwise> choice.
   --  When all the choice conditions were false, the component tree is built,
   --  the children of this node are evaluated.
   type Otherwise_Tag_Node is new Tag_Node with null record;
   type Otherwise_Tag_Node_Access is access all Otherwise_Tag_Node'Class;

   --  Create the Otherwise Tag
   function Create_Otherwise_Tag_Node (Binding    : in Binding_Access;
                                       Line       : in Line_Info;
                                       Parent     : in Tag_Node_Access;
                                       Attributes : in Tag_Attribute_Array_Access)
                                       return Tag_Node_Access;

   --  Java Facelet provides a <c:repeat> tag.  It must not be implemented
   --  because it was proven this was not a good method for iterating over a list.
private

   type Set_Tag_Node is new Tag_Node with record
      Var   : Tag_Attribute_Access;
      Value : Tag_Attribute_Access;
   end record;

   type If_Tag_Node is new Tag_Node with record
      Condition : Tag_Attribute_Access;
      Var       : Tag_Attribute_Access;
   end record;

   type When_Tag_Node is new If_Tag_Node with record
      Next_Choice : When_Tag_Node_Access;
   end record;

   type Choose_Tag_Node is new Tag_Node with record
      Choices   : When_Tag_Node_Access;
      Otherwise : Tag_Node_Access;
   end record;

end ASF.Views.Nodes.Core;

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

--  The <b>ASF.Views.Nodes.Core</b> package defines some pre-defined
--  core tag nodes which are mapped in the following namespaces:
--
--    xmlns:c="http://java.sun.com/jstl/core"
--    xmlns:ui="http://java.sun.com/jsf/facelets"
--    xmlns:fn="http://java.sun.com/jsp/jstl/functions"
--
--  The following JSTL core elements are defined:
--    <c:set var="name" value="#{expr}"/>
--    <c:if test="#{expr}"> ...</c:if>
--    <c:choose><c:when test="#{expr}"></c:when><c:otherwise/</c:choose>
--
--
with ASF.Factory;
with EL.Functions;
package ASF.Views.Nodes.Core is

   FN_URI : constant String := "http://java.sun.com/jsp/jstl/functions";

   --  Register the facelets component factory.
   procedure Register (Factory : in out ASF.Factory.Component_Factory);

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://java.sun.com/jsp/jstl/functions"
   --  Functions:
   --    capitalize, toUpperCase, toLowerCase
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   --  ------------------------------
   --  Set Tag
   --  ------------------------------
   --  The <c:set var="name" value="#{expr}"/> variable creation.
   --  The variable is created in the faces context.
   type Set_Tag_Node is new Tag_Node with private;
   type Set_Tag_Node_Access is access all Set_Tag_Node'Class;

   --  Create the Set Tag
   function Create_Set_Tag_Node (Binding    : in Binding_Type;
                                 Line       : in Line_Info;
                                 Parent     : in Tag_Node_Access;
                                 Attributes : in Tag_Attribute_Array_Access)
                                 return Tag_Node_Access;

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access Set_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  ------------------------------
   --  If Tag
   --  ------------------------------
   --  The <c:if test="#{expr}"> ...</c:if> condition.
   --  If the condition evaluates to true when the component tree is built,
   --  the children of this node are evaluated.  Otherwise the entire
   --  sub-tree is not present in the component tree.
   type If_Tag_Node is new Tag_Node with private;
   type If_Tag_Node_Access is access all If_Tag_Node'Class;

   --  Create the If Tag
   function Create_If_Tag_Node (Binding    : in Binding_Type;
                                Line       : in Line_Info;
                                Parent     : in Tag_Node_Access;
                                Attributes : in Tag_Attribute_Array_Access)
                                return Tag_Node_Access;

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access If_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  ------------------------------
   --  Choose Tag
   --  ------------------------------
   --  The <c:choose> ...</c:choose> choice.
   --  Evaluate a set of choices (<c:when>) until one of them is found.
   --  When no choice is found, evaluate the <c:otherwise> node.
   type Choose_Tag_Node is new Tag_Node with private;
   type Choose_Tag_Node_Access is access all Choose_Tag_Node'Class;

   --  Freeze the tag node tree and perform any initialization steps
   --  necessary to build the components efficiently.
   --  Prepare the evaluation of choices by identifying the <c:when> and
   --  <c:otherwise> conditions.
   overriding
   procedure Freeze (Node : access Choose_Tag_Node);

   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   overriding
   procedure Build_Components (Node    : access Choose_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class);

   --  Create the <c:choose> tag node
   function Create_Choose_Tag_Node (Binding    : in Binding_Type;
                                    Line       : in Line_Info;
                                    Parent     : in Tag_Node_Access;
                                    Attributes : in Tag_Attribute_Array_Access)
                                   return Tag_Node_Access;

   --  ------------------------------
   --  When Tag
   --  ------------------------------
   --  The <c:when test="#{expr}"> ...</c:when> choice.
   --  If the condition evaluates to true when the component tree is built,
   --  the children of this node are evaluated.  Otherwise the entire
   --  sub-tree is not present in the component tree.
   type When_Tag_Node is new If_Tag_Node with private;
   type When_Tag_Node_Access is access all When_Tag_Node'Class;

   --  Check whether the node condition is selected.
   function Is_Selected (Node    : When_Tag_Node;
                         Context : Facelet_Context'Class) return Boolean;

   --  Create the When Tag
   function Create_When_Tag_Node (Binding    : in Binding_Type;
                                  Line       : in Line_Info;
                                  Parent     : in Tag_Node_Access;
                                  Attributes : in Tag_Attribute_Array_Access)
                                 return Tag_Node_Access;

   --  ------------------------------
   --  Otherwise Tag
   --  ------------------------------
   --  The <c:otherwise> ...</c:otherwise> choice.
   --  When all the choice conditions were false, the component tree is built,
   --  the children of this node are evaluated.
   type Otherwise_Tag_Node is new Tag_Node with null record;
   type Otherwise_Tag_Node_Access is access all Otherwise_Tag_Node'Class;

   --  Create the Otherwise Tag
   function Create_Otherwise_Tag_Node (Binding    : in Binding_Type;
                                       Line       : in Line_Info;
                                       Parent     : in Tag_Node_Access;
                                       Attributes : in Tag_Attribute_Array_Access)
                                       return Tag_Node_Access;

   --  Java Facelet provides a <c:repeat> tag.  It must not be implemented
   --  because it was proven this was not a good method for iterating over a list.
private

   type Set_Tag_Node is new Tag_Node with record
      Var   : Tag_Attribute_Access;
      Value : Tag_Attribute_Access;
   end record;

   type If_Tag_Node is new Tag_Node with record
      Condition : Tag_Attribute_Access;
      Var       : Tag_Attribute_Access;
   end record;

   type When_Tag_Node is new If_Tag_Node with record
      Next_Choice : When_Tag_Node_Access;
   end record;

   type Choose_Tag_Node is new Tag_Node with record
      Choices   : When_Tag_Node_Access;
      Otherwise : Tag_Node_Access;
   end record;

end ASF.Views.Nodes.Core;

Use Binding_Type instead of Binding_Access


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

with Util.Files;
with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Plugins is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;

      function Get_Directory_Name (Name     : in String;
                                   Name_Dir : in Ada.Strings.Unbounded.Unbounded_String)
        return String;

      function Get_Directory_Name (Name     : in String;
                                   Name_Dir : in Ada.Strings.Unbounded.Unbounded_String)
                                   return String is
      begin
         if Ada.Strings.Unbounded.Length (Name_Dir) = 0 then
            return Name;
         else
            return Ada.Strings.Unbounded.To_String (Name_Dir);
         end if;
      end Get_Directory_Name;

      Result_Dir : constant String := Generator.Get_Result_Directory;
      Name_Dir   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: d:") is
         when ASCII.NUL => exit;

         when 'd' =>
            Name_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      declare
         Name  : constant String := Get_Argument;
         Kind  : constant String := Get_Argument;
         Dir   : constant String := Generator.Get_Plugin_Directory;
         Path  : constant String := Util.Files.Compose (Dir, Get_Directory_Name (Name, Name_Dir));
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing plugin name");
            Gen.Commands.Usage;
            return;
         end if;
         if Kind /= "ada" and Kind /= "web" then
            Generator.Error ("Invalid plugin type (must be 'ada' or 'web')");
            return;
         end if;

         if Ada.Directories.Exists (Path) then
            Generator.Error ("Plugin {0} exists already", Name);
            return;
         end if;
         if not Ada.Directories.Exists (Dir) then
            Ada.Directories.Create_Directory (Dir);
         end if;
         Ada.Directories.Create_Directory (Path);

         Generator.Set_Result_Directory (Path);

         --  Create the plugin project instance and generate its dynamo.xml file.
         --  The new plugin is added to the current project so that it will be referenced.
         declare
            procedure Create_Plugin (Project : in out Model.Projects.Root_Project_Definition);

            procedure Create_Plugin (Project : in out Model.Projects.Root_Project_Definition) is
               Plugin : Gen.Model.Projects.Project_Definition_Access;
               File   : constant String := Util.Files.Compose (Path, "dynamo.xml");
            begin
               Project.Create_Project (Name    => Name,
                                       Path    => File,
                                       Project => Plugin);
               Project.Add_Module (Plugin);

               Plugin.Props.Set ("license", Project.Props.Get ("license", "none"));
               Plugin.Props.Set ("author", Project.Props.Get ("author", ""));
               Plugin.Props.Set ("author_email", Project.Props.Get ("author_email", ""));
               Plugin.Save (File);
            end Create_Plugin;

         begin
            Generator.Update_Project (Create_Plugin'Access);
         end;

         --  Generate the new plugin content.
         Generator.Set_Force_Save (False);
         Generator.Set_Global ("pluginName", Name);
         Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE,
                                     "create-plugin-" & Kind);

         --  And save the project dynamo.xml file which now refers to the new plugin.
         Generator.Set_Result_Directory (Result_Dir);
         Generator.Save_Project;

      exception
         when Ada.Directories.Name_Error | Ada.Directories.Use_Error =>
            Generator.Error ("Cannot create directory {0}", Path);
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-plugin: Create a new plugin for the current project");
      Put_Line ("Usage: create-plugin [-l apache|gpl|gpl3|mit|bsd3|proprietary] "
                & "[-d DIR] NAME [ada | web]");
      New_Line;
      Put_Line ("  Creates a new AWA plugin for the application with the name passed in NAME.");
      Put_Line ("  The plugin license is controlled by the -l option.");
      Put_Line ("  The plugin type is specified as the last argument which can be one of:");
      New_Line;
      Put_Line ("    ada  the plugin contains Ada code and a GNAT project is created");
      Put_Line ("    web  the plugin contains XHTML, CSS, Javascript files only");
      New_Line;
      Put_Line ("  The -d option allows to control the plugin directory name.  The plugin NAME");
      Put_Line ("  is used by default.  The plugin is created in the directory:");
      Put_Line ("    plugins/NAME or plugins/DIR");
      New_Line;
      Put_Line ("  For the Ada plugin, the command generates the following files"
                & " in the plugin directory:");
      Put_Line ("    src/<project>-<plugin>.ads");
      Put_Line ("    src/<project>-<plugin>-<module>.ads");
      Put_Line ("    src/<project>-<plugin>-<module>.adb");
   end Help;

end Gen.Commands.Plugins;

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

with Util.Files;
with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Plugins is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name, Args);
      use GNAT.Command_Line;

      function Get_Directory_Name (Name     : in String;
                                   Name_Dir : in Ada.Strings.Unbounded.Unbounded_String)
        return String;

      function Get_Directory_Name (Name     : in String;
                                   Name_Dir : in Ada.Strings.Unbounded.Unbounded_String)
                                   return String is
      begin
         if Ada.Strings.Unbounded.Length (Name_Dir) = 0 then
            return Name;
         else
            return Ada.Strings.Unbounded.To_String (Name_Dir);
         end if;
      end Get_Directory_Name;

      Result_Dir : constant String := Generator.Get_Result_Directory;
      Name_Dir   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: d:") is
         when ASCII.NUL => exit;

         when 'd' =>
            Name_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      declare
         Name  : constant String := Get_Argument;
         Kind  : constant String := Get_Argument;
         Dir   : constant String := Generator.Get_Plugin_Directory;
         Path  : constant String := Util.Files.Compose (Dir, Get_Directory_Name (Name, Name_Dir));
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing plugin name");
            Gen.Commands.Usage;
            return;
         end if;
         if Kind /= "ada" and Kind /= "web" then
            Generator.Error ("Invalid plugin type (must be 'ada' or 'web')");
            return;
         end if;

         if Ada.Directories.Exists (Path) then
            Generator.Error ("Plugin {0} exists already", Name);
            return;
         end if;
         if not Ada.Directories.Exists (Dir) then
            Ada.Directories.Create_Directory (Dir);
         end if;
         Ada.Directories.Create_Directory (Path);

         Generator.Set_Result_Directory (Path);

         --  Create the plugin project instance and generate its dynamo.xml file.
         --  The new plugin is added to the current project so that it will be referenced.
         declare
            procedure Create_Plugin (Project : in out Model.Projects.Root_Project_Definition);

            procedure Create_Plugin (Project : in out Model.Projects.Root_Project_Definition) is
               Plugin : Gen.Model.Projects.Project_Definition_Access;
               File   : constant String := Util.Files.Compose (Path, "dynamo.xml");
            begin
               Project.Create_Project (Name    => Name,
                                       Path    => File,
                                       Project => Plugin);
               Project.Add_Module (Plugin);

               Plugin.Props.Set ("license", Project.Props.Get ("license", "none"));
               Plugin.Props.Set ("author", Project.Props.Get ("author", ""));
               Plugin.Props.Set ("author_email", Project.Props.Get ("author_email", ""));
               Plugin.Save (File);
            end Create_Plugin;

         begin
            Generator.Update_Project (Create_Plugin'Access);
         end;

         --  Generate the new plugin content.
         Generator.Set_Force_Save (False);
         Generator.Set_Global ("pluginName", Name);
         Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE,
                                     "create-plugin-" & Kind);

         --  And save the project dynamo.xml file which now refers to the new plugin.
         Generator.Set_Result_Directory (Result_Dir);
         Generator.Save_Project;

      exception
         when Ada.Directories.Name_Error | Ada.Directories.Use_Error =>
            Generator.Error ("Cannot create directory {0}", Path);
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-plugin: Create a new plugin for the current project");
      Put_Line ("Usage: create-plugin [-l apache|gpl|gpl3|mit|bsd3|proprietary] "
                & "[-d DIR] NAME [ada | web]");
      New_Line;
      Put_Line ("  Creates a new AWA plugin for the application with the name passed in NAME.");
      Put_Line ("  The plugin license is controlled by the -l option.");
      Put_Line ("  The plugin type is specified as the last argument which can be one of:");
      New_Line;
      Put_Line ("    ada  the plugin contains Ada code and a GNAT project is created");
      Put_Line ("    web  the plugin contains XHTML, CSS, Javascript files only");
      New_Line;
      Put_Line ("  The -d option allows to control the plugin directory name.  The plugin NAME");
      Put_Line ("  is used by default.  The plugin is created in the directory:");
      Put_Line ("    plugins/NAME or plugins/DIR");
      New_Line;
      Put_Line ("  For the Ada plugin, the command generates the following files"
                & " in the plugin directory:");
      Put_Line ("    src/<project>-<plugin>.ads");
      Put_Line ("    src/<project>-<plugin>-<module>.ads");
      Put_Line ("    src/<project>-<plugin>-<module>.adb");
   end Help;

end Gen.Commands.Plugins;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  util-dates-formats-tests - Test for date formats
--  Copyright (C) 2011, 2013, 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.Tests;
package Util.Dates.Formats.Tests is

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

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

   procedure Test_Format (T : in out Test);

   --  Test the Get_Day_Start operation.
   procedure Test_Get_Day_Start (T : in out Test);

   --  Test the Get_Week_Start operation.
   procedure Test_Get_Week_Start (T : in out Test);

   --  Test the Get_Month_Start operation.
   procedure Test_Get_Month_Start (T : in out Test);

   --  Test the Get_Day_End operation.
   procedure Test_Get_Day_End (T : in out Test);

   --  Test the Get_Week_End operation.
   procedure Test_Get_Week_End (T : in out Test);

   --  Test the Get_Month_End operation.
   procedure Test_Get_Month_End (T : in out Test);

   --  Test the Split operation.
   procedure Test_Split (T : in out Test);

   --  Test the Append_Date operation
   procedure Test_Append_Date (T : in out Test);

   --  Test the ISO8601 operations.
   procedure Test_ISO8601 (T : in out Test);

end Util.Dates.Formats.Tests;

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

with Util.Tests;
package Util.Dates.Formats.Tests is

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

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

   procedure Test_Format (T : in out Test);

   --  Test parsing a date using several formats and different locales.
   procedure Test_Parse (T : in out Test);

   --  Test the Get_Day_Start operation.
   procedure Test_Get_Day_Start (T : in out Test);

   --  Test the Get_Week_Start operation.
   procedure Test_Get_Week_Start (T : in out Test);

   --  Test the Get_Month_Start operation.
   procedure Test_Get_Month_Start (T : in out Test);

   --  Test the Get_Day_End operation.
   procedure Test_Get_Day_End (T : in out Test);

   --  Test the Get_Week_End operation.
   procedure Test_Get_Week_End (T : in out Test);

   --  Test the Get_Month_End operation.
   procedure Test_Get_Month_End (T : in out Test);

   --  Test the Split operation.
   procedure Test_Split (T : in out Test);

   --  Test the Append_Date operation
   procedure Test_Append_Date (T : in out Test);

   --  Test the ISO8601 operations.
   procedure Test_ISO8601 (T : in out Test);

end Util.Dates.Formats.Tests;

Declare the Test_Parse procedure to test the date parsing


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

--  == Rolling file manager ==
--  The `Util.Files.Rolling` package provides a simple support to roll a file
--  based on some rolling policy.  Such rolling is traditionally used for file
--  logs to move files to another place when they reach some size limit or when
--  some date conditions are met (such as a day change).  The file manager uses
--  a file path and a pattern.  The file path is used to define the default
--  or initial file.  The pattern is used when rolling occurs to decide how
--  to reorganize files.
--
--  The file manager defines a triggering policy represented by `Policy_Type`.
--  It controls when the file rolling must be made.
--
--  * `No_Policy`: no policy, the rolling must be triggered manually.
--  * `Size_Policy`: size policy, the rolling is triggered when the file
--     reaches a given size.
--  * `Time_Policy`: time policy, the rolling is made when the date/time pattern
--     no longer applies to the active file.
--
--  To control how the rolling is made, the `Strategy_Type` defines the behavior
--  of the rolling.
--
--  * `Rollover_Strategy`:
--  * `Direct_Strategy`:
--
--  To use the file manager, the first step is to create an instance and configure
--  the default file, pattern, choose the triggering policy and strategy:
--
--    Manager : Util.Files.Rolling.File_Manager;
--
--    Manager.Initialize ("dynamo.log", "dynamo-%i.log",
--                        Policy => (Size_Policy, 100_000),
--                        Strategy => (Rollover_Strategy, 1, 10));
--
--  After the initialization, the current file is retrieved by using the
--  `Get_Current_Path` function and you should call `Is_Rollover_Necessary`
--  before writing content on the file.  When it returns `True`, it means you
--  should call the `Rollover` procedure that will perform roll over according
--  to the rolling strategy.
--
package Util.Files.Rolling is

   type Policy_Kind is (No_Policy, Size_Policy, Time_Policy);

   type Policy_Type (Kind : Policy_Kind) is record
      case Kind is
         when No_Policy =>
            null;

         when Size_Policy =>
            Size : Ada.Directories.File_Size := 100_000_000;

         when Time_Policy =>
            Interval : Natural := 1;

      end case;
   end record;

   type Strategy_Kind is (Ascending_Strategy,
                          Descending_Strategy,
                          Direct_Strategy);

   type Strategy_Type (Kind : Strategy_Kind) is record
      case Kind is
         when Ascending_Strategy | Descending_Strategy =>
            Min_Index : Natural;
            Max_Index : Natural;

         when Direct_Strategy =>
            Max_Files : Natural;

      end case;
   end record;

   --  Format the file pattern with the date and index to produce a file path.
   function Format (Pattern : in String;
                    Date    : in Ada.Calendar.Time;
                    Index   : in Natural) return String;

   type File_Manager is tagged limited private;

   --  Initialize the file manager to roll the file refered by `Path` by using
   --  the pattern defined in `Pattern`.
   procedure Initialize (Manager  : in out File_Manager;
                         Path     : in String;
                         Pattern  : in String;
                         Policy   : in Policy_Type;
                         Strategy : in Strategy_Type);

   --  Get the current path (it may or may not exist).
   function Get_Current_Path (Manager : in File_Manager) return String;

   --  Check if a rollover is necessary based on the rolling strategy.
   function Is_Rollover_Necessary (Manager : in File_Manager) return Boolean;

   --  Perform a rollover according to the strategy that was configured.
   procedure Rollover (Manager : in out File_Manager);

   procedure Rollover_Ascending (Manager : in out File_Manager);
   procedure Rollover_Descending (Manager : in out File_Manager);
   procedure Rollover_Direct (Manager : in out File_Manager);

   --  Get the regex pattern to identify a file that must be purged.
   --  The default is to extract the file pattern part of the file manager pattern.
   function Get_Purge_Pattern (Manager : in File_Manager) return String;

private

   --  Find the files that are elligible to purge in the given directory.
   procedure Elligible_Files (Manager     : in out File_Manager;
                              Path        : in String;
                              Names       : in out Util.Strings.Vectors.Vector;
                              First_Index : out Natural;
                              Last_Index  : out Natural);

   procedure Rename (Manager : in File_Manager;
                     Old     : in String);

   procedure Purge (Manager : in out File_Manager;
                    Path    : in String);

   type File_Manager is tagged limited record
      Policy    : Policy_Kind := No_Policy;
      Strategy  : Strategy_Kind := Ascending_Strategy;
      File_Path : Unbounded_String;
      Pattern   : Unbounded_String;
      Interval  : Natural;
      Cur_Index : Natural := 1;
      Min_Index : Natural;
      Max_Index : Natural;
      Max_Files : Natural := 1;
      Deadline  : Ada.Calendar.Time;
      Max_Size  : Ada.Directories.File_Size := Ada.Directories.File_Size'Last;
   end record;

end Util.Files.Rolling;

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

--  == Rolling file manager ==
--  The `Util.Files.Rolling` package provides a simple support to roll a file
--  based on some rolling policy.  Such rolling is traditionally used for file
--  logs to move files to another place when they reach some size limit or when
--  some date conditions are met (such as a day change).  The file manager uses
--  a file path and a pattern.  The file path is used to define the default
--  or initial file.  The pattern is used when rolling occurs to decide how
--  to reorganize files.
--
--  The file manager defines a triggering policy represented by `Policy_Type`.
--  It controls when the file rolling must be made.
--
--  * `No_Policy`: no policy, the rolling must be triggered manually.
--  * `Size_Policy`: size policy, the rolling is triggered when the file
--     reaches a given size.
--  * `Time_Policy`: time policy, the rolling is made when the date/time pattern
--     no longer applies to the active file.
--
--  To control how the rolling is made, the `Strategy_Type` defines the behavior
--  of the rolling.
--
--  * `Rollover_Strategy`:
--  * `Direct_Strategy`:
--
--  To use the file manager, the first step is to create an instance and configure
--  the default file, pattern, choose the triggering policy and strategy:
--
--    Manager : Util.Files.Rolling.File_Manager;
--
--    Manager.Initialize ("dynamo.log", "dynamo-%i.log",
--                        Policy => (Size_Policy, 100_000),
--                        Strategy => (Rollover_Strategy, 1, 10));
--
--  After the initialization, the current file is retrieved by using the
--  `Get_Current_Path` function and you should call `Is_Rollover_Necessary`
--  before writing content on the file.  When it returns `True`, it means you
--  should call the `Rollover` procedure that will perform roll over according
--  to the rolling strategy.
--
package Util.Files.Rolling is

   type Policy_Kind is (No_Policy, Size_Policy, Time_Policy);

   type Policy_Type (Kind : Policy_Kind) is record
      case Kind is
         when No_Policy =>
            null;

         when Size_Policy =>
            Size : Ada.Directories.File_Size := 100_000_000;

         when Time_Policy =>
            Interval : Natural := 1;

      end case;
   end record;

   type Strategy_Kind is (Ascending_Strategy,
                          Descending_Strategy,
                          Direct_Strategy);

   type Strategy_Type (Kind : Strategy_Kind) is record
      case Kind is
         when Ascending_Strategy | Descending_Strategy =>
            Min_Index : Natural;
            Max_Index : Natural;

         when Direct_Strategy =>
            Max_Files : Natural;

      end case;
   end record;

   --  Format the file pattern with the date and index to produce a file path.
   function Format (Pattern : in String;
                    Date    : in Ada.Calendar.Time;
                    Index   : in Natural) return String;

   type File_Manager is tagged limited private;

   --  Initialize the file manager to roll the file refered by `Path` by using
   --  the pattern defined in `Pattern`.
   procedure Initialize (Manager  : in out File_Manager;
                         Path     : in String;
                         Pattern  : in String;
                         Policy   : in Policy_Type;
                         Strategy : in Strategy_Type);

   --  Get the current path (it may or may not exist).
   function Get_Current_Path (Manager : in File_Manager) return String;

   --  Check if a rollover is necessary based on the rolling strategy.
   function Is_Rollover_Necessary (Manager : in File_Manager) return Boolean;

   --  Perform a rollover according to the strategy that was configured.
   procedure Rollover (Manager : in out File_Manager);

   procedure Rollover_Ascending (Manager : in out File_Manager);
   procedure Rollover_Descending (Manager : in out File_Manager);
   procedure Rollover_Direct (Manager : in out File_Manager);

   --  Get the regex pattern to identify a file that must be purged.
   --  The default is to extract the file pattern part of the file manager pattern.
   function Get_Purge_Pattern (Manager : in File_Manager) return String;

private

   --  Find the files that are elligible to purge in the given directory.
   procedure Elligible_Files (Manager     : in out File_Manager;
                              Path        : in String;
                              Names       : in out Util.Strings.Vectors.Vector;
                              First_Index : out Natural;
                              Last_Index  : out Natural);

   procedure Rename (Manager : in File_Manager;
                     Old     : in String);

   type File_Manager is tagged limited record
      Policy    : Policy_Kind := No_Policy;
      Strategy  : Strategy_Kind := Ascending_Strategy;
      File_Path : Unbounded_String;
      Pattern   : Unbounded_String;
      Interval  : Natural;
      Cur_Index : Natural := 1;
      Min_Index : Natural;
      Max_Index : Natural;
      Max_Files : Natural := 1;
      Deadline  : Ada.Calendar.Time;
      Max_Size  : Ada.Directories.File_Size := Ada.Directories.File_Size'Last;
   end record;

end Util.Files.Rolling;

Remove unused Purge procedure

Remove unused Purge procedure


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

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

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

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

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

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

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

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

   protected body Memory_Allocator is

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

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

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

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

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

      begin
         if Old_Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
         else
            Used_Slots.Insert (Addr, Slot);
         end if;
         Remove_Free (Addr, Slot.Size);
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

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

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

   end Memory_Allocator;

end MAT.Memory.Targets;

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

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

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

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

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

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

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

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

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

   protected body Memory_Allocator is

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

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

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

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

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

      begin
         if Old_Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
         else
            Used_Slots.Insert (Addr, Slot);
         end if;
         Remove_Free (Addr, Slot.Size);
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

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

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

   end Memory_Allocator;

end MAT.Memory.Targets;

Implement the Find procedure on the Target_Memory object