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

with Util.Strings;
with ASF.Utils;
package body ASF.Components.Html.Selects is

   --  ------------------------------
   --  UISelectItem Component
   --  ------------------------------

   ITEM_LABEL_NAME       : constant String := "itemLabel";
   ITEM_VALUE_NAME       : constant String := "itemValue";
   ITEM_DESCRIPTION_NAME : constant String := "itemDescription";
   ITEM_DISABLED_NAME    : constant String := "itemDisabled";

   SELECT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Iterator over the Select_Item elements
   --  ------------------------------

   --  ------------------------------
   --  Get an iterator to scan the component children.
   --  ------------------------------
   procedure First (UI       : in UISelectOne'Class;
                    Context  : in Faces_Context'Class;
                    Iterator : out Cursor) is
   begin
      Iterator.Component := UI.First;
      Iterator.Pos       := 0;
      Iterator.Last      := 0;
      while ASF.Components.Base.Has_Element (Iterator.Component) loop
         Iterator.Current := ASF.Components.Base.Element (Iterator.Component);
         if Iterator.Current.all in UISelectItem'Class then
            return;
         end if;
         if Iterator.Current.all in UISelectItems'Class then
            Iterator.List := UISelectItems'Class (Iterator.Current.all)
              .Get_Select_Item_List (Context);
            Iterator.Last := Iterator.List.Length;
            Iterator.Pos  := 1;
            if Iterator.Last > 0 then
               return;
            end if;
         end if;
         ASF.Components.Base.Next (Iterator.Component);
      end loop;
      Iterator.Pos := 0;
      Iterator.Current := null;
   end First;

   --  ------------------------------
   --  Returns True if the iterator points to a valid child.
   --  ------------------------------
   function Has_Element (Pos : in Cursor) return Boolean is
      use type ASF.Components.Base.UIComponent_Access;
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return True;
      else
         return Pos.Current /= null;
      end if;
   end Has_Element;

   --  ------------------------------
   --  Get the child component pointed to by the iterator.
   --  ------------------------------
   function Element (Pos     : in Cursor;
                     Context : in Faces_Context'Class) return ASF.Models.Selects.Select_Item is
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return Pos.List.Get_Select_Item (Pos.Pos);
      else
         return UISelectItem'Class (Pos.Current.all).Get_Select_Item (Context);
      end if;
   end Element;

   --  ------------------------------
   --  Move to the next child.
   --  ------------------------------
   procedure Next (Pos     : in out Cursor;
                   Context : in Faces_Context'Class) is
   begin
      if Pos.Pos > 0 and Pos.Pos < Pos.Last then
         Pos.Pos := Pos.Pos + 1;
      else
         Pos.Pos := 0;
         loop
            Pos.Current := null;
            ASF.Components.Base.Next (Pos.Component);
            exit when not ASF.Components.Base.Has_Element (Pos.Component);
            Pos.Current := ASF.Components.Base.Element (Pos.Component);
            exit when Pos.Current.all in UISelectItem'Class;
            if Pos.Current.all in UISelectItems'Class then
               Pos.List := UISelectItems'Class (Pos.Current.all).Get_Select_Item_List (Context);
               Pos.Last := Pos.List.Length;
               Pos.Pos  := 1;
               exit when Pos.Last > 0;
               Pos.Pos := 0;
            end if;
         end loop;
      end if;
   end Next;

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item (From    : in UISelectItem;
                             Context : in Faces_Context'Class)
                             return ASF.Models.Selects.Select_Item is
      use Util.Beans.Objects;

      Val : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                   Context => Context);
   begin
      if not Is_Null (Val) then
         return ASF.Models.Selects.To_Select_Item (Val);
      end if;
      declare
         Label       : constant Object := From.Get_Attribute (Name    => ITEM_LABEL_NAME,
                                                              Context => Context);
         Value       : constant Object := From.Get_Attribute (Name    => ITEM_VALUE_NAME,
                                                              Context => Context);
         Description : constant Object := From.Get_Attribute (Name    => ITEM_DESCRIPTION_NAME,
                                                              Context => Context);
         Disabled    : constant Boolean := From.Get_Attribute (Name   => ITEM_DISABLED_NAME,
                                                               Context => Context);
      begin
         return ASF.Models.Selects.Create_Select_Item (Label, Value, Description, Disabled);
      end;
   end Get_Select_Item;

   --  ------------------------------
   --  UISelectItems Component
   --  ------------------------------

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item_List (From : in UISelectItems;
                                  Context : in Faces_Context'Class)
                                     return ASF.Models.Selects.Select_Item_List is
      use Util.Beans.Objects;

      Value : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                     Context => Context);
   begin
      return ASF.Models.Selects.To_Select_Item_List (Value);
   end Get_Select_Item_List;

   --  ------------------------------
   --  SelectOne Component
   --  ------------------------------

   --  ------------------------------
   --  Render the select element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UISelectOne;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UISelectOne'Class (UI).Render_Select (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   procedure Render_Select (UI      : in UISelectOne;
                            Context : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("select");
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer);

      UISelectOne'Class (UI).Render_Options (Value, Context);
      Writer.End_Element ("select");
   end Render_Select;

   --  ------------------------------
   --  Renders the option element.  This is called by Render_Select to
   --  generate the component options.
   --  ------------------------------
   procedure Render_Options (UI      : in UISelectOne;
                             Value   : in Util.Beans.Objects.Object;
                             Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
   begin
      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            Writer.Start_Element ("option");
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("selected", "selected");
            end if;
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("option");
            Next (Iter, Context);
         end;
      end loop;
   end Render_Options;

begin
   ASF.Utils.Set_Text_Attributes (SELECT_ATTRIBUTE_NAMES);
   ASF.Utils.Set_Interactive_Attributes (SELECT_ATTRIBUTE_NAMES);
end ASF.Components.Html.Selects;

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

with Util.Strings;
with ASF.Utils;
package body ASF.Components.Html.Selects is

   --  ------------------------------
   --  UISelectItem Component
   --  ------------------------------

   ITEM_LABEL_NAME       : constant String := "itemLabel";
   ITEM_VALUE_NAME       : constant String := "itemValue";
   ITEM_DESCRIPTION_NAME : constant String := "itemDescription";
   ITEM_DISABLED_NAME    : constant String := "itemDisabled";

   SELECT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Iterator over the Select_Item elements
   --  ------------------------------

   --  ------------------------------
   --  Get an iterator to scan the component children.
   --  ------------------------------
   procedure First (UI       : in UISelectOne'Class;
                    Context  : in Faces_Context'Class;
                    Iterator : out Cursor) is
   begin
      Iterator.Component := UI.First;
      Iterator.Pos       := 0;
      Iterator.Last      := 0;
      while ASF.Components.Base.Has_Element (Iterator.Component) loop
         Iterator.Current := ASF.Components.Base.Element (Iterator.Component);
         if Iterator.Current.all in UISelectItem'Class then
            return;
         end if;
         if Iterator.Current.all in UISelectItems'Class then
            Iterator.List := UISelectItems'Class (Iterator.Current.all)
              .Get_Select_Item_List (Context);
            Iterator.Last := Iterator.List.Length;
            Iterator.Pos  := 1;
            if Iterator.Last > 0 then
               return;
            end if;
         end if;
         ASF.Components.Base.Next (Iterator.Component);
      end loop;
      Iterator.Pos := 0;
      Iterator.Current := null;
   end First;

   --  ------------------------------
   --  Returns True if the iterator points to a valid child.
   --  ------------------------------
   function Has_Element (Pos : in Cursor) return Boolean is
      use type ASF.Components.Base.UIComponent_Access;
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return True;
      else
         return Pos.Current /= null;
      end if;
   end Has_Element;

   --  ------------------------------
   --  Get the child component pointed to by the iterator.
   --  ------------------------------
   function Element (Pos     : in Cursor;
                     Context : in Faces_Context'Class) return ASF.Models.Selects.Select_Item is
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return Pos.List.Get_Select_Item (Pos.Pos);
      else
         return UISelectItem'Class (Pos.Current.all).Get_Select_Item (Context);
      end if;
   end Element;

   --  ------------------------------
   --  Move to the next child.
   --  ------------------------------
   procedure Next (Pos     : in out Cursor;
                   Context : in Faces_Context'Class) is
   begin
      if Pos.Pos > 0 and Pos.Pos < Pos.Last then
         Pos.Pos := Pos.Pos + 1;
      else
         Pos.Pos := 0;
         loop
            Pos.Current := null;
            ASF.Components.Base.Next (Pos.Component);
            exit when not ASF.Components.Base.Has_Element (Pos.Component);
            Pos.Current := ASF.Components.Base.Element (Pos.Component);
            exit when Pos.Current.all in UISelectItem'Class;
            if Pos.Current.all in UISelectItems'Class then
               Pos.List := UISelectItems'Class (Pos.Current.all).Get_Select_Item_List (Context);
               Pos.Last := Pos.List.Length;
               Pos.Pos  := 1;
               exit when Pos.Last > 0;
               Pos.Pos := 0;
            end if;
         end loop;
      end if;
   end Next;

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item (From    : in UISelectItem;
                             Context : in Faces_Context'Class)
                             return ASF.Models.Selects.Select_Item is
      use Util.Beans.Objects;

      Val : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                   Context => Context);
   begin
      if not Is_Null (Val) then
         return ASF.Models.Selects.To_Select_Item (Val);
      end if;
      declare
         Label       : constant Object := From.Get_Attribute (Name    => ITEM_LABEL_NAME,
                                                              Context => Context);
         Value       : constant Object := From.Get_Attribute (Name    => ITEM_VALUE_NAME,
                                                              Context => Context);
         Description : constant Object := From.Get_Attribute (Name    => ITEM_DESCRIPTION_NAME,
                                                              Context => Context);
         Disabled    : constant Boolean := From.Get_Attribute (Name   => ITEM_DISABLED_NAME,
                                                               Context => Context);
      begin
         if Is_Null (Label) then
            return ASF.Models.Selects.Create_Select_Item (Value, Value, Description, Disabled);
         else
            return ASF.Models.Selects.Create_Select_Item (Label, Value, Description, Disabled);
         end if;
      end;
   end Get_Select_Item;

   --  ------------------------------
   --  UISelectItems Component
   --  ------------------------------

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item_List (From : in UISelectItems;
                                  Context : in Faces_Context'Class)
                                     return ASF.Models.Selects.Select_Item_List is
      use Util.Beans.Objects;

      Value : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                     Context => Context);
   begin
      return ASF.Models.Selects.To_Select_Item_List (Value);
   end Get_Select_Item_List;

   --  ------------------------------
   --  SelectOne Component
   --  ------------------------------

   --  ------------------------------
   --  Render the select element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UISelectOne;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UISelectOne'Class (UI).Render_Select (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   procedure Render_Select (UI      : in UISelectOne;
                            Context : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("select");
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer);

      UISelectOne'Class (UI).Render_Options (Value, Context);
      Writer.End_Element ("select");
   end Render_Select;

   --  ------------------------------
   --  Renders the option element.  This is called by Render_Select to
   --  generate the component options.
   --  ------------------------------
   procedure Render_Options (UI      : in UISelectOne;
                             Value   : in Util.Beans.Objects.Object;
                             Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
   begin
      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            Writer.Start_Element ("option");
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("selected", "selected");
            end if;
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("option");
            Next (Iter, Context);
         end;
      end loop;
   end Render_Options;

begin
   ASF.Utils.Set_Text_Attributes (SELECT_ATTRIBUTE_NAMES);
   ASF.Utils.Set_Interactive_Attributes (SELECT_ATTRIBUTE_NAMES);
end ASF.Components.Html.Selects;

Use the select item value as label if the label is not specified


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

with Ada.Unchecked_Deallocation;
with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

   use Util.Log;

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

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Rule) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Case'Class,
                                                        Navigation_Access);
   begin
      while not Controller.Navigators.Is_Empty loop
         declare
            Iter      : Navigator_Vector.Cursor := Controller.Navigators.Last;
            Navigator : Navigation_Access := Navigator_Vector.Element (Iter);
         begin
            Free (Navigator.Outcome);
            Free (Navigator.Action);
            Free (Navigator);
            Controller.Navigators.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Navigation_Rules) is
      procedure Free is new Ada.Unchecked_Deallocation (Rule'Class, Rule_Access);
   begin
      while not Controller.Rules.Is_Empty loop
         declare
            Iter : Rule_Map.Cursor := Controller.Rules.First;
            Rule : Rule_Access := Rule_Map.Element (Iter);
         begin
            Rule.Clear;
            Free (Rule);
            Controller.Rules.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  Provide a default navigation rules for the view and the outcome when no application
   --  navigation was found.  The default looks for an XHTML file in the same directory as
   --  the view and which has the base name defined by Outcome.
   --  ------------------------------
   procedure Handle_Default_Navigation (Handler : in Navigation_Handler;
                                        View    : in String;
                                        Outcome : in String;
                                        Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Pos          : constant Natural := Util.Strings.Rindex (View, '/');
      Root         : Components.Root.UIViewRoot;
      View_Handler : access ASF.Applications.Views.View_Handler'Class := Handler.View_Handler;
   begin
      if View_Handler = null then
         View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Pos > 0 then
         declare
            Name : constant String := View (View'First .. Pos) & Outcome;
         begin
            Log.Debug ("Using default navigatation from view {0} to {1}", View, Name);

            View_Handler.Create_View (Name, Context, Root);
         end;
      else
         Log.Debug ("Using default navigatation from view {0} to {1}", View, View);

         View_Handler.Create_View (Outcome, Context, Root);
      end if;

      --  If the 'outcome' refers to a real view, use it.  Otherwise keep the current view.
      if Components.Root.Get_Root (Root) /= null then
         Context.Set_View_Root (Root);
      end if;

      exception
         when others =>
         Log.Debug ("No suitable navigation rule to navigate from view {0}: {1}",
                    View, Outcome);
         raise;

   end Handle_Default_Navigation;

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access;

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := N - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      else
         Log.Debug ("No navigation rule found for view {0}, action {1} and outcome {2}",
                    Name, Action, Outcome);

         Navigation_Handler'Class (Handler).Handle_Default_Navigation (Name, Outcome, Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Rules, Navigation_Rules_Access);
   begin
      if Handler.Rules /= null then
         Clear (Handler.Rules.all);
         Free (Handler.Rules);
      end if;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is
      C : constant Navigation_Access := Render.Create_Render_Navigator (To);
   begin
      Handler.Add_Navigation_Case (C, From, Outcome, Action, Condition);
   end Add_Navigation_Case;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  by using the navigation rule defined by Navigator.
   --  Some optional conditions are evaluated:
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler'Class;
                                  Navigator : in Navigation_Access;
                                  From      : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is
      pragma Unreferenced (Condition);

   begin
      Log.Info ("Add navigation from {0} with outcome {1}", From, Outcome);

      if Outcome'Length > 0 then
         Navigator.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         Navigator.Action := new String '(Action);
      end if;

      if Handler.View_Handler = null then
         Handler.View_Handler := Handler.Application.Get_View_Handler;
      end if;

      Navigator.View_Handler := Handler.View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (Navigator);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

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

with Ada.Unchecked_Deallocation;
with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

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

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Rule) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Case'Class,
                                                        Navigation_Access);
   begin
      while not Controller.Navigators.Is_Empty loop
         declare
            Iter      : Navigator_Vector.Cursor := Controller.Navigators.Last;
            Navigator : Navigation_Access := Navigator_Vector.Element (Iter);
         begin
            Free (Navigator.Outcome);
            Free (Navigator.Action);
            Free (Navigator);
            Controller.Navigators.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Navigation_Rules) is
      procedure Free is new Ada.Unchecked_Deallocation (Rule'Class, Rule_Access);
   begin
      while not Controller.Rules.Is_Empty loop
         declare
            Iter : Rule_Map.Cursor := Controller.Rules.First;
            Rule : Rule_Access := Rule_Map.Element (Iter);
         begin
            Rule.Clear;
            Free (Rule);
            Controller.Rules.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  Provide a default navigation rules for the view and the outcome when no application
   --  navigation was found.  The default looks for an XHTML file in the same directory as
   --  the view and which has the base name defined by Outcome.
   --  ------------------------------
   procedure Handle_Default_Navigation (Handler : in Navigation_Handler;
                                        View    : in String;
                                        Outcome : in String;
                                        Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Pos          : constant Natural := Util.Strings.Rindex (View, '/');
      Root         : Components.Root.UIViewRoot;
      View_Handler : access ASF.Applications.Views.View_Handler'Class := Handler.View_Handler;
   begin
      if View_Handler = null then
         View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Pos > 0 then
         declare
            Name : constant String := View (View'First .. Pos) & Outcome;
         begin
            Log.Debug ("Using default navigation from view {0} to {1}", View, Name);

            View_Handler.Create_View (Name, Context, Root);
         end;
      else
         Log.Debug ("Using default navigation from view {0} to {1}", View, View);

         View_Handler.Create_View (Outcome, Context, Root);
      end if;

      --  If the 'outcome' refers to a real view, use it.  Otherwise keep the current view.
      if Components.Root.Get_Root (Root) /= null then
         Context.Set_View_Root (Root);
      end if;

      exception
         when others =>
         Log.Debug ("No suitable navigation rule to navigate from view {0}: {1}",
                    View, Outcome);
         raise;

   end Handle_Default_Navigation;

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access;

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := N - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      else
         Log.Debug ("No navigation rule found for view {0}, action {1} and outcome {2}",
                    Name, Action, Outcome);

         Navigation_Handler'Class (Handler).Handle_Default_Navigation (Name, Outcome, Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Rules, Navigation_Rules_Access);
   begin
      if Handler.Rules /= null then
         Clear (Handler.Rules.all);
         Free (Handler.Rules);
      end if;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is
      C : constant Navigation_Access := Render.Create_Render_Navigator (To);
   begin
      Handler.Add_Navigation_Case (C, From, Outcome, Action, Condition);
   end Add_Navigation_Case;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  by using the navigation rule defined by Navigator.
   --  Some optional conditions are evaluated:
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler'Class;
                                  Navigator : in Navigation_Access;
                                  From      : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is
      pragma Unreferenced (Condition);

   begin
      Log.Info ("Add navigation from {0} with outcome {1}", From, Outcome);

      if Outcome'Length > 0 then
         Navigator.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         Navigator.Action := new String '(Action);
      end if;

      if Handler.View_Handler = null then
         Handler.View_Handler := Handler.Application.Get_View_Handler;
      end if;

      Navigator.View_Handler := Handler.View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (Navigator);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

Fix log messages in navigation rules.

Fix log messages in navigation rules.


-----------------------------------------------------------------------
--  util-texts-builders_tests -- Unit tests for text builders
--  Copyright (C) 2013, 2016, 2017, 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.Strings.Unbounded;
with Ada.Text_IO;

with Util.Test_Caller;
with Util.Texts.Builders;
with Util.Measures;

package body Util.Texts.Builders_Tests is

   package String_Builder is new Util.Texts.Builders (Element_Type => Character,
                                                      Input        => String,
                                                      Chunk_Size   => 100);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Length",
                       Test_Length'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Append",
                       Test_Append'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Clear",
                       Test_Clear'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Iterate",
                       Test_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Inline_Iterate",
                       Test_Inline_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Tail",
                       Test_Tail'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Perf",
                       Test_Perf'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the length operation.
   --  ------------------------------
   procedure Test_Length (T : in out Test) is
      B : String_Builder.Builder (10);
   begin
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 10, String_Builder.Capacity (B), "Invalid capacity");
   end Test_Length;

   --  ------------------------------
   --  Test the append operation.
   --  ------------------------------
   procedure Test_Append (T : in out Test) is
      S : constant String := "0123456789";
      B : String_Builder.Builder (3);
   begin
      String_Builder.Append (B, "a string");
      Util.Tests.Assert_Equals (T, 8, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string", String_Builder.To_Array (B), "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      --  Append new string and check content.
      String_Builder.Append (B, " b string");
      Util.Tests.Assert_Equals (T, 17, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string b string", String_Builder.To_Array (B),
                                "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      for I in S'Range loop
         String_Builder.Append (B, S (I));
      end loop;
      Util.Tests.Assert_Equals (T, 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, S, String_Builder.To_Array (B), "Invalid append");
   end Test_Append;

   --  ------------------------------
   --  Test the clear operation.
   --  ------------------------------
   procedure Test_Clear (T : in out Test) is
      B : String_Builder.Builder (7);
   begin
      for I in 1 .. 10 loop
         String_Builder.Append (B, "a string");
      end loop;
      Util.Tests.Assert_Equals (T, 8 * 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 100 + 7, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length after clear");
      Util.Tests.Assert_Equals (T, 7, String_Builder.Capacity (B), "Invalid capacity after clear");
   end Test_Clear;

   --  ------------------------------
   --  Test the tail operation.
   --  ------------------------------
   procedure Test_Tail (T : in out Test) is

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural);

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural) is
         P : constant String := "0123456789";
         B : String_Builder.Builder (Min);
      begin
         for I in 1 .. Max loop
            String_Builder.Append (B, P (1 + (I mod 10)));
         end loop;
         declare
            S  : constant String := String_Builder.Tail (B, L);
            S2 : constant String := String_Builder.To_Array (B);
         begin
            Util.Tests.Assert_Equals (T, Max, S2'Length, "Invalid length");
            if L >= Max then
               Util.Tests.Assert_Equals (T, S2, S, "Invalid Tail result");
            else
               Util.Tests.Assert_Equals (T, S2 (S2'Last - L + 1 .. S2'Last), S,
                                         "Invalid Tail result {"
                                         & Positive'Image (Min) & ","
                                         & Positive'Image (Max) & ","
                                         & Positive'Image (L) & "]");
            end if;
         end;
      end Check_Tail;

   begin
      for I in 1 .. 100 loop
         for J in 1 .. 8 loop
            for K in 1 .. I + 3 loop
               Check_Tail (J, I, K);
            end loop;
         end loop;
      end loop;
   end Test_Tail;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      String_Builder.Iterate (B, Process'Access);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Iterate;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Inline_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;

      procedure Get is new String_Builder.Inline_Iterate (Process);
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      Get (B);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Inline_Iterate;

   --  ------------------------------
   --  Test the append and iterate performance.
   --  ------------------------------
   procedure Test_Perf (T : in out Test) is
      Perf : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string-append.csv"));
      Ada.Text_IO.Put_Line (Perf, "Block_Size,Append Time,To_Array Time,Iterate Time");
      for Block_Size in 1 .. 300 loop
         declare
            B : String_Builder.Builder (10);
            N : constant String := Natural'Image (Block_Size * 10) & ",";
         begin
            String_Builder.Set_Block_Size (B, Block_Size * 10);
            declare
               S : Util.Measures.Stamp;
            begin
               for I in 1 .. 1000 loop
                  String_Builder.Append (B, "some item");
               end loop;
               Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);
            end;
            declare
               S : Util.Measures.Stamp;
               R : constant String := String_Builder.To_Array (B);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (R'Length > 0, "Invalid string length");
            end;

            declare
               Count : Natural := 0;

               procedure Process (Item : in String);

               procedure Process (Item : in String) is
                  pragma Unreferenced (Item);
               begin
                  Count := Count + 1;
               end Process;

               S : Util.Measures.Stamp;
            begin
               String_Builder.Iterate (B, Process'Access);
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (Count > 0, "The string builder was empty");
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
      Ada.Text_IO.Close (Perf);

      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string.csv"));
      Ada.Text_IO.Put_Line (Perf, "Size,Append (100),Append (512),"
                            & "Append (1024),Unbounded,Iterate Time");
      for I in 1 .. 4000 loop
         declare
            N  : constant String := Natural'Image (I) & ",";
            B  : String_Builder.Builder (10);
            B2 : String_Builder.Builder (10);
            B3 : String_Builder.Builder (10);
            U  : Ada.Strings.Unbounded.Unbounded_String;
            S  : Util.Measures.Stamp;
         begin
            for J in 1 .. I loop
               String_Builder.Append (B, "some item");
            end loop;
            Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B2, 512);
            for J in 1 .. I loop
               String_Builder.Append (B2, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B3, 1024);
            for J in 1 .. I loop
               String_Builder.Append (B3, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            for J in 1 .. I loop
               Ada.Strings.Unbounded.Append (U, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            declare
               R : constant String := String_Builder.To_Array (B);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;

            declare
               R : constant String := Ada.Strings.Unbounded.To_String (U);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
   end Test_Perf;

end Util.Texts.Builders_Tests;

-----------------------------------------------------------------------
--  util-texts-builders_tests -- Unit tests for text builders
--  Copyright (C) 2013, 2016, 2017, 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.Strings.Unbounded;
with Ada.Text_IO;

with Util.Test_Caller;
with Util.Texts.Builders;
with Util.Measures;

package body Util.Texts.Builders_Tests is

   package String_Builder is new Util.Texts.Builders (Element_Type => Character,
                                                      Input        => String,
                                                      Chunk_Size   => 100);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Length",
                       Test_Length'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Append",
                       Test_Append'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Inline_Append",
                       Test_Inline_Append'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Clear",
                       Test_Clear'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Iterate",
                       Test_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Inline_Iterate",
                       Test_Inline_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Tail",
                       Test_Tail'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Perf",
                       Test_Perf'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the length operation.
   --  ------------------------------
   procedure Test_Length (T : in out Test) is
      B : String_Builder.Builder (10);
   begin
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 10, String_Builder.Capacity (B), "Invalid capacity");
   end Test_Length;

   --  ------------------------------
   --  Test the append operation.
   --  ------------------------------
   procedure Test_Append (T : in out Test) is
      S : constant String := "0123456789";
      B : String_Builder.Builder (3);
   begin
      String_Builder.Append (B, "a string");
      Util.Tests.Assert_Equals (T, 8, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string", String_Builder.To_Array (B), "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      --  Append new string and check content.
      String_Builder.Append (B, " b string");
      Util.Tests.Assert_Equals (T, 17, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string b string", String_Builder.To_Array (B),
                                "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      for I in S'Range loop
         String_Builder.Append (B, S (I));
      end loop;
      Util.Tests.Assert_Equals (T, 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, S, String_Builder.To_Array (B), "Invalid append");
   end Test_Append;

   --  ------------------------------
   --  Test the append operation.
   --  ------------------------------
   procedure Test_Inline_Append (T : in out Test) is
      procedure Append (Into : in out String;
                        Last : out Natural);

      S : constant String := "0123456789";
      I : Positive := S'First;
      B : String_Builder.Builder (3);

      procedure Append (Into : in out String;
                        Last : out Natural) is
         Pos : Natural := Into'First;
      begin
         while Pos <= Into'Last and I <= S'Last loop
            Into (Pos) := S (I);
            Pos := Pos + 1;
            I := I + 1;
         end loop;
         Last := Pos - 1;
      end Append;

      procedure Fill is new String_Builder.Inline_Append (Append);

   begin
      Fill (B);
      Util.Tests.Assert_Equals (T, S'Length, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "0123456789", String_Builder.To_Array (B), "Invalid content");

      I := S'First;
      Fill (B);
      Util.Tests.Assert_Equals (T, "01234567890123456789",
                                String_Builder.To_Array (B), "Invalid content");

      String_Builder.Clear (B);
      I := S'Last;
      Fill (B);
      Util.Tests.Assert_Equals (T, "9", String_Builder.To_Array (B), "Invalid content");

      String_Builder.Clear (B);
      I := S'Last + 1;
      Fill (B);
      Util.Tests.Assert_Equals (T, "", String_Builder.To_Array (B), "Invalid content");
   end Test_Inline_Append;

   --  ------------------------------
   --  Test the clear operation.
   --  ------------------------------
   procedure Test_Clear (T : in out Test) is
      B : String_Builder.Builder (7);
   begin
      for I in 1 .. 10 loop
         String_Builder.Append (B, "a string");
      end loop;
      Util.Tests.Assert_Equals (T, 8 * 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 100 + 7, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length after clear");
      Util.Tests.Assert_Equals (T, 7, String_Builder.Capacity (B), "Invalid capacity after clear");
   end Test_Clear;

   --  ------------------------------
   --  Test the tail operation.
   --  ------------------------------
   procedure Test_Tail (T : in out Test) is

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural);

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural) is
         P : constant String := "0123456789";
         B : String_Builder.Builder (Min);
      begin
         for I in 1 .. Max loop
            String_Builder.Append (B, P (1 + (I mod 10)));
         end loop;
         declare
            S  : constant String := String_Builder.Tail (B, L);
            S2 : constant String := String_Builder.To_Array (B);
         begin
            Util.Tests.Assert_Equals (T, Max, S2'Length, "Invalid length");
            if L >= Max then
               Util.Tests.Assert_Equals (T, S2, S, "Invalid Tail result");
            else
               Util.Tests.Assert_Equals (T, S2 (S2'Last - L + 1 .. S2'Last), S,
                                         "Invalid Tail result {"
                                         & Positive'Image (Min) & ","
                                         & Positive'Image (Max) & ","
                                         & Positive'Image (L) & "]");
            end if;
         end;
      end Check_Tail;

   begin
      for I in 1 .. 100 loop
         for J in 1 .. 8 loop
            for K in 1 .. I + 3 loop
               Check_Tail (J, I, K);
            end loop;
         end loop;
      end loop;
   end Test_Tail;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      String_Builder.Iterate (B, Process'Access);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Iterate;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Inline_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;

      procedure Get is new String_Builder.Inline_Iterate (Process);
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      Get (B);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Inline_Iterate;

   --  ------------------------------
   --  Test the append and iterate performance.
   --  ------------------------------
   procedure Test_Perf (T : in out Test) is
      Perf : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string-append.csv"));
      Ada.Text_IO.Put_Line (Perf, "Block_Size,Append Time,To_Array Time,Iterate Time");
      for Block_Size in 1 .. 300 loop
         declare
            B : String_Builder.Builder (10);
            N : constant String := Natural'Image (Block_Size * 10) & ",";
         begin
            String_Builder.Set_Block_Size (B, Block_Size * 10);
            declare
               S : Util.Measures.Stamp;
            begin
               for I in 1 .. 1000 loop
                  String_Builder.Append (B, "some item");
               end loop;
               Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);
            end;
            declare
               S : Util.Measures.Stamp;
               R : constant String := String_Builder.To_Array (B);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (R'Length > 0, "Invalid string length");
            end;

            declare
               Count : Natural := 0;

               procedure Process (Item : in String);

               procedure Process (Item : in String) is
                  pragma Unreferenced (Item);
               begin
                  Count := Count + 1;
               end Process;

               S : Util.Measures.Stamp;
            begin
               String_Builder.Iterate (B, Process'Access);
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (Count > 0, "The string builder was empty");
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
      Ada.Text_IO.Close (Perf);

      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string.csv"));
      Ada.Text_IO.Put_Line (Perf, "Size,Append (100),Append (512),"
                            & "Append (1024),Unbounded,Iterate Time");
      for I in 1 .. 4000 loop
         declare
            N  : constant String := Natural'Image (I) & ",";
            B  : String_Builder.Builder (10);
            B2 : String_Builder.Builder (10);
            B3 : String_Builder.Builder (10);
            U  : Ada.Strings.Unbounded.Unbounded_String;
            S  : Util.Measures.Stamp;
         begin
            for J in 1 .. I loop
               String_Builder.Append (B, "some item");
            end loop;
            Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B2, 512);
            for J in 1 .. I loop
               String_Builder.Append (B2, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B3, 1024);
            for J in 1 .. I loop
               String_Builder.Append (B3, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            for J in 1 .. I loop
               Ada.Strings.Unbounded.Append (U, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            declare
               R : constant String := String_Builder.To_Array (B);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;

            declare
               R : constant String := Ada.Strings.Unbounded.To_String (U);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
   end Test_Perf;

end Util.Texts.Builders_Tests;

Implement Test_Inline_Append and register the new test for execution


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

with Ada.Strings.Unbounded;
with Ada.Exceptions;

with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Contexts;
with EL.Contexts.TLS;
with EL.Variables;
with EL.Variables.Default;

with ASF.Beans;
with ASF.Requests;
with ASF.Sessions;

with AWA.Events.Action_Method;
package body AWA.Events.Dispatchers.Actions is

   use Ada.Strings.Unbounded;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Actions");

   --  ------------------------------
   --  Dispatch the event identified by Event.
   --  The event actions which are associated with the event are executed synchronously.
   --  ------------------------------
   overriding
   procedure Dispatch (Manager : in Action_Dispatcher;
                       Event   : in Module_Event'Class) is

      use Util.Beans.Objects;

      --  Dispatch the event to the event action identified by Action.
      procedure Dispatch_One (Action : in Event_Action);

      type Event_Bean is new Util.Beans.Basic.Readonly_Bean with null record;

      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      --  ------------------------------
      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object is
         pragma Unreferenced (From);
      begin
         return Event.Get_Value (Name);
      end Get_Value;

      Variables      : aliased EL.Variables.Default.Default_Variable_Mapper;

      --  ------------------------------
      --  Default Resolver
      --  ------------------------------
      type Event_ELResolver is limited new EL.Contexts.ELResolver with record
         Request     : ASF.Requests.Request_Access;
         Application : AWA.Applications.Application_Access;
      end record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
         use Util.Beans.Basic;
         use type ASF.Requests.Request_Access;

         Result : Object;
         Bean   : Util.Beans.Basic.Readonly_Bean_Access;
         Scope  : ASF.Beans.Scope_Type;
         Key    : constant String := To_String (Name);
      begin
         if Base /= null then
            return Base.Get_Value (Key);
         end if;

         if Resolver.Request /= null then
            Result := Resolver.Request.Get_Attribute (Key);
            if not Util.Beans.Objects.Is_Null (Result) then
               return Result;
            end if;

            --  If there is a session, look if the attribute is defined there.
            declare
               Session : constant ASF.Sessions.Session := Resolver.Request.Get_Session;
            begin
               if Session.Is_Valid then
                  Result := Session.Get_Attribute (Key);
                  if not Util.Beans.Objects.Is_Null (Result) then
                     return Result;
                  end if;
               end if;
            end;
         end if;

         Resolver.Application.Create (Name, Context, Bean, Scope);
         if Bean = null then
            return Resolver.Application.Get_Global (Name, Context);
         end if;
         Result := To_Object (Bean);
         if Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Key, Result);
         else
            Variables.Bind (Key, Result);
         end if;
         return Result;
      end Get_Value;

      --  ------------------------------
      --  Set the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object) is
         pragma Unreferenced (Context);
         use type ASF.Requests.Request_Access;

         Key : constant String := To_String (Name);
      begin
         if Base /= null then
            Base.Set_Value (Name => Key, Value => Value);
         elsif Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Name => Key, Value => Value);
         else
            Variables.Bind (To_String (Name), Value);
         end if;
      end Set_Value;

      Local_Event    : aliased Event_Bean;
      Resolver       : aliased Event_ELResolver;
      ELContext      : aliased EL.Contexts.TLS.TLS_Context;

      --  ------------------------------
      --  Dispatch the event to the event action identified by Action.
      --  ------------------------------
      procedure Dispatch_One (Action : in Event_Action) is
         use Ada.Exceptions;

         Method : EL.Expressions.Method_Info;
      begin
         Method := Action.Action.Get_Method_Info (Context => ELContext);

         if Method.Object.all in Util.Beans.Basic.Bean'Class then
            --  If we have a prepare method and the bean provides a Set_Value method,
            --  call the preparation method to fill the bean with some values.
            EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Method.Object.all),
                                 Action.Properties,
                                 ELContext);
         end if;

         --  Execute the specified method on the bean and give it the event object.
         AWA.Events.Action_Method.Execute (Method => Method,
                                           Param  => Event);

         --  If an exception is raised by the action, do not propagate it:
         --   o We have to dispatch the event to other actions.
         --   o The event may be dispatched asynchronously and there is no handler
         --     that could handle such exception
      exception
         when E : others =>
            Log.Error ("Error when executing event action {0}: {1}: {2}",
                       Action.Action.Get_Expression, Exception_Name (E), Exception_Message (E));
      end Dispatch_One;

      Pos  : Event_Action_Lists.Cursor := Manager.Actions.First;
   begin
      Resolver.Application := Manager.Application;

      ELContext.Set_Resolver (Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Variables.Bind (Name  => "event",
                      Value => To_Object (Local_Event'Unchecked_Access, STATIC));

      while Event_Action_Lists.Has_Element (Pos) loop
         Event_Action_Lists.Query_Element (Pos, Dispatch_One'Access);
         Event_Action_Lists.Next (Pos);
      end loop;
   end Dispatch;

   --  ------------------------------
   --  Add an action invoked when an event is dispatched through this dispatcher.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   overriding
   procedure Add_Action (Manager : in out Action_Dispatcher;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is

      Item : Event_Action;
   begin
      Item.Action     := Action;
      Item.Properties := Params;
      Manager.Actions.Append (Item);
   end Add_Action;

   --  ------------------------------
   --  Create a new dispatcher associated with the application.
   --  ------------------------------
   function Create_Dispatcher (Application : in AWA.Applications.Application_Access)
                               return Dispatcher_Access is
      Result : constant Dispatcher_Access := new Action_Dispatcher '(Dispatcher with
                                                                     Application => Application,
                                                                     others => <>);
   begin
      return Result.all'Access;
   end Create_Dispatcher;

end AWA.Events.Dispatchers.Actions;

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

with Ada.Strings.Unbounded;
with Ada.Exceptions;

with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Contexts;
with EL.Contexts.TLS;
with EL.Variables;
with EL.Variables.Default;

with ASF.Beans;
with ASF.Requests;
with ASF.Sessions;

with AWA.Events.Action_Method;
package body AWA.Events.Dispatchers.Actions is

   use Ada.Strings.Unbounded;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Actions");

   --  ------------------------------
   --  Dispatch the event identified by Event.
   --  The event actions which are associated with the event are executed synchronously.
   --  ------------------------------
   overriding
   procedure Dispatch (Manager : in Action_Dispatcher;
                       Event   : in Module_Event'Class) is

      use Util.Beans.Objects;

      --  Dispatch the event to the event action identified by Action.
      procedure Dispatch_One (Action : in Event_Action);

      type Event_Bean is new Util.Beans.Basic.Readonly_Bean with null record;

      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      --  ------------------------------
      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object is
         pragma Unreferenced (From);
      begin
         return Event.Get_Value (Name);
      end Get_Value;

      Variables      : aliased EL.Variables.Default.Default_Variable_Mapper;

      --  ------------------------------
      --  Default Resolver
      --  ------------------------------
      type Event_ELResolver is limited new EL.Contexts.ELResolver with record
         Request     : ASF.Requests.Request_Access;
         Application : AWA.Applications.Application_Access;
      end record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
         use Util.Beans.Basic;
         use type ASF.Requests.Request_Access;

         Result : Object;
         Bean   : Util.Beans.Basic.Readonly_Bean_Access;
         Scope  : ASF.Beans.Scope_Type;
         Key    : constant String := To_String (Name);
      begin
         if Base /= null then
            return Base.Get_Value (Key);
         end if;

         if Resolver.Request /= null then
            Result := Resolver.Request.Get_Attribute (Key);
            if not Util.Beans.Objects.Is_Null (Result) then
               return Result;
            end if;

            --  If there is a session, look if the attribute is defined there.
            declare
               Session : constant ASF.Sessions.Session := Resolver.Request.Get_Session;
            begin
               if Session.Is_Valid then
                  Result := Session.Get_Attribute (Key);
                  if not Util.Beans.Objects.Is_Null (Result) then
                     return Result;
                  end if;
               end if;
            end;
         end if;

         Resolver.Application.Create (Name, Context, Bean, Scope);
         if Bean = null then
            return Resolver.Application.Get_Global (Name, Context);
         end if;
         Result := To_Object (Bean);
         if Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Key, Result);
         else
            Variables.Bind (Key, Result);
         end if;
         return Result;
      end Get_Value;

      --  ------------------------------
      --  Set the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object) is
         pragma Unreferenced (Context);
         use type ASF.Requests.Request_Access;

         Key : constant String := To_String (Name);
      begin
         if Base /= null then
            Base.Set_Value (Name => Key, Value => Value);
         elsif Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Name => Key, Value => Value);
         else
            Variables.Bind (To_String (Name), Value);
         end if;
      end Set_Value;

      Local_Event    : aliased Event_Bean;
      Resolver       : aliased Event_ELResolver;
      ELContext      : aliased EL.Contexts.TLS.TLS_Context;

      --  ------------------------------
      --  Dispatch the event to the event action identified by Action.
      --  ------------------------------
      procedure Dispatch_One (Action : in Event_Action) is
         use Ada.Exceptions;

         Method : EL.Expressions.Method_Info;
         Bean   : access Util.Beans.Basic.Readonly_Bean'Class;
      begin
         Method := Action.Action.Get_Method_Info (Context => ELContext);

         Bean := Util.Beans.Objects.To_Bean (Method.Object);
         if Bean /= null and then Bean.all in Util.Beans.Basic.Bean'Class then
            --  If we have a prepare method and the bean provides a Set_Value method,
            --  call the preparation method to fill the bean with some values.
            EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Bean.all),
                                 Action.Properties,
                                 ELContext);
         end if;

         --  Execute the specified method on the bean and give it the event object.
         AWA.Events.Action_Method.Execute (Method => Method,
                                           Param  => Event);

         --  If an exception is raised by the action, do not propagate it:
         --   o We have to dispatch the event to other actions.
         --   o The event may be dispatched asynchronously and there is no handler
         --     that could handle such exception
      exception
         when E : others =>
            Log.Error ("Error when executing event action {0}: {1}: {2}",
                       Action.Action.Get_Expression, Exception_Name (E), Exception_Message (E));
      end Dispatch_One;

      Pos  : Event_Action_Lists.Cursor := Manager.Actions.First;
   begin
      Resolver.Application := Manager.Application;

      ELContext.Set_Resolver (Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Variables.Bind (Name  => "event",
                      Value => To_Object (Local_Event'Unchecked_Access, STATIC));

      while Event_Action_Lists.Has_Element (Pos) loop
         Event_Action_Lists.Query_Element (Pos, Dispatch_One'Access);
         Event_Action_Lists.Next (Pos);
      end loop;
   end Dispatch;

   --  ------------------------------
   --  Add an action invoked when an event is dispatched through this dispatcher.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   overriding
   procedure Add_Action (Manager : in out Action_Dispatcher;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is

      Item : Event_Action;
   begin
      Item.Action     := Action;
      Item.Properties := Params;
      Manager.Actions.Append (Item);
   end Add_Action;

   --  ------------------------------
   --  Create a new dispatcher associated with the application.
   --  ------------------------------
   function Create_Dispatcher (Application : in AWA.Applications.Application_Access)
                               return Dispatcher_Access is
      Result : constant Dispatcher_Access := new Action_Dispatcher '(Dispatcher with
                                                                     Application => Application,
                                                                     others => <>);
   begin
      return Result.all'Access;
   end Create_Dispatcher;

end AWA.Events.Dispatchers.Actions;

Fix compilation with GNAT 2020

Fix compilation with GNAT 2020