awa_2.4.0_59135a52/ada-asf/src/asf-views-nodes.adb

-----------------------------------------------------------------------
--  asf-views-nodes -- Facelet node tree representation
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2018, 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 EL.Contexts.Default;
with ASF.Components.Core;
with ASF.Contexts.Writer;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;
with Util.Log.Loggers;
package body ASF.Views.Nodes is

   use EL.Expressions;

   procedure Free is
     new Ada.Unchecked_Deallocation (Tag_Node'Class,
                                     Tag_Node_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Tag_Attribute_Array,
                                     Tag_Attribute_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Tag_Content,
                                     Tag_Content_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (EL.Expressions.Expression'Class,
                                     EL.Expressions.Expression_Access);

   use Util.Log;

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

   --  ------------------------------
   --  Attribute of a node.
   --  ------------------------------

   --  ------------------------------
   --  Report an error message for the attribute.
   --  ------------------------------
   procedure Error (Attribute : in Tag_Attribute;
                    Message   : in String;
                    Param1    : in String;
                    Param2    : in String := "") is
   begin
      if Attribute.Tag /= null then
         Attribute.Tag.Error (Message, Param1, Param2);
      else
         Log.Error (Message, Param1, Param2);
      end if;
   end Error;

   --  ------------------------------
   --  Compare the attribute name.
   --  ------------------------------
   function "=" (Left : in Tag_Attribute; Right : in String) return Boolean is
   begin
      return Left.Name = Right;
   end "=";

   overriding
   function "=" (Left, Right : in Tag_Attribute) return Boolean is
   begin
      return Left.Name = Right.Name;
   end "=";

   --  ------------------------------
   --  Get the attribute name.
   --  ------------------------------
   function Get_Name (Attribute : Tag_Attribute) return String is
   begin
      return To_String (Attribute.Name);
   end Get_Name;

   --  ------------------------------
   --  Returns True if the attribute is static (not an EL expression).
   --  ------------------------------
   function Is_Static (Attribute : Tag_Attribute) return Boolean is
   begin
      return Attribute.Binding = null;
   end Is_Static;

   --  ------------------------------
   --  Get the attribute value.  If the attribute is an EL expression
   --  evaluate that expression in the context of the given UI component.
   --  ------------------------------
   function Get_Value (Attribute : Tag_Attribute;
                       UI        : UIComponent'Class) return EL.Objects.Object is

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence);

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence) is
      begin
         Error (Attribute, "Evaluation error: {0}", Ada.Exceptions.Exception_Message (E));
      end Handle_Exception;

   begin
      if Attribute.Binding /= null then
         declare
            Ctx     : constant EL.Contexts.ELContext_Access := UI.Get_Context.Get_ELContext;
            Context : EL.Contexts.Default.Guarded_Context (Handle_Exception'Access, Ctx);
         begin
            return Attribute.Binding.Get_Value (Context);
         end;
      else
         return EL.Objects.To_Object (Attribute.Value);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the attribute value.  If the attribute is an EL expression
   --  evaluate that expression in the context of the given UI component.
   --  ------------------------------
   function Get_Value (Attribute : Tag_Attribute;
                       Context   : Faces_Context'Class) return EL.Objects.Object is

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence);

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence) is
      begin
         Error (Attribute, "Evaluation error: {0}", Ada.Exceptions.Exception_Message (E));
      end Handle_Exception;

   begin
      if Attribute.Binding /= null then
         declare
            Ctx     : constant EL.Contexts.ELContext_Access := Context.Get_ELContext;
            Context : EL.Contexts.Default.Guarded_Context (Handle_Exception'Access, Ctx);
         begin
            return Attribute.Binding.Get_Value (Context);
         end;
      else
         return EL.Objects.To_Object (Attribute.Value);
      end if;
   end Get_Value;

   function Get_Value (Attribute : Tag_Attribute;
                       Context   : Facelet_Context'Class) return EL.Objects.Object is

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence);

      procedure Handle_Exception (E : in Ada.Exceptions.Exception_Occurrence) is
      begin
         Error (Attribute, "Evaluation error: {0}", Ada.Exceptions.Exception_Message (E));
      end Handle_Exception;
   begin
      if Attribute.Binding /= null then
         declare
            Ctx     : constant EL.Contexts.ELContext_Access := Context.Get_ELContext;
            Context : EL.Contexts.Default.Guarded_Context (Handle_Exception'Access, Ctx);
         begin
            return Attribute.Binding.Get_Value (Context);
         end;
      else
         return EL.Objects.To_Object (Attribute.Value);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the value from the attribute.  If the attribute is null or evaluates to
   --  a NULL object, returns the default value.  Convert the value into a string.
   --  ------------------------------
   function Get_Value (Attribute : in Tag_Attribute_Access;
                       Context   : in Facelet_Context'Class;
                       Default   : in String) return String is
   begin
      if Attribute = null then
         return Default;
      else
         declare
            Value : constant EL.Objects.Object := Get_Value (Attribute.all, Context);
         begin
            if EL.Objects.Is_Null (Value) then
               return Default;
            else
               return EL.Objects.To_String (Value);
            end if;
         end;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the EL expression associated with the given tag attribute.
   --  ------------------------------
   function Get_Expression (Attribute : in Tag_Attribute)
                            return EL.Expressions.Expression is
   begin
      if Attribute.Binding /= null then
         return EL.Expressions.Expression (Attribute.Binding.all);
      else
         return EL.Expressions.Create_Expression (EL.Objects.To_Object (Attribute.Value));
      end if;
   end Get_Expression;

   function Get_Value_Expression (Attribute : Tag_Attribute)
                                  return EL.Expressions.Value_Expression is
   begin
      if Attribute.Binding /= null then
         return EL.Expressions.Create_Expression (Attribute.Binding.all);
      else
         return EL.Expressions.Create_ValueExpression (EL.Objects.To_Object (Attribute.Value));
      end if;
   end Get_Value_Expression;

   function Get_Method_Expression (Attribute : Tag_Attribute)
                                   return EL.Expressions.Method_Expression is
   begin
      if Attribute.Binding /= null then
         return EL.Expressions.Create_Expression (Attribute.Binding.all);
      else
         Error (Attribute, "Invalid method expression", "");
         raise Constraint_Error with "Invalid method expression";
      end if;
   end Get_Method_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   function Reduce_Expression (Attribute : Tag_Attribute;
                               Context   : Facelet_Context'Class)
                               return EL.Expressions.Expression is
      E : constant EL.Expressions.Expression
        := EL.Expressions.Expression (Attribute.Binding.all);
   begin
      return E.Reduce_Expression (Context.Get_ELContext.all);
   end Reduce_Expression;

   --  ------------------------------
   --  Find the tag attribute having the given name.
   --  Returns an access to the attribute cell within the array or null
   --  if the no attribute matches the name.
   --  ------------------------------
   function Find_Attribute (Attributes : Tag_Attribute_Array_Access;
                            Name       : String) return Tag_Attribute_Access is
   begin
      for I in Attributes'Range loop
         declare
            Attr : constant Tag_Attribute_Access := Attributes (I)'Access;
         begin
            if Attr.Name = Name then
               return Attr;
            end if;
         end;
      end loop;
      return null;
   end Find_Attribute;

   --  ------------------------------
   --  XHTML node
   --  ------------------------------

   --  ------------------------------
   --  Get the line information where the tag node is defined.
   --  ------------------------------
   function Get_Line_Info (Node : Tag_Node) return Line_Info is
   begin
      return Node.Line;
   end Get_Line_Info;

   --  ------------------------------
   --  Get the line information as a string.
   --  ------------------------------
   function Get_Line_Info (Node : Tag_Node) return String is
      L : constant String := Natural'Image (Node.Line.Line);
      C : constant String := Natural'Image (Node.Line.Column);
   begin
      if Node.Line.File = null then
         return "?:"
           & L (L'First + 1 .. L'Last)
           & ':' & C (C'First + 1 .. C'Last);
      else
         return Node.Line.File.Path
           & ':' & L (L'First + 1 .. L'Last)
           & ':' & C (C'First + 1 .. C'Last);
      end if;
   end Get_Line_Info;

   --  ------------------------------
   --  Get the relative path name of the XHTML file in which this tag is defined.
   --  ------------------------------
   function Get_File_Name (Node : in Tag_Node) return String is
      File : constant File_Info_Access := Node.Line.File;
   begin
      return File.Path (File.Relative_Pos .. File.Path'Last);
   end Get_File_Name;

   --  ------------------------------
   --  Get the node attribute with the given name.
   --  Returns null if the node does not have such attribute.
   --  ------------------------------
   function Get_Attribute (Node : Tag_Node;
                           Name : String) return Tag_Attribute_Access is
   begin
      if Node.Attributes = null then
         return null;
      end if;
      return Find_Attribute (Node.Attributes, Name);
   end Get_Attribute;

   --  ------------------------------
   --  Initialize the node
   --  ------------------------------
   procedure Initialize (Node       : in Tag_Node_Access;
                         Binding    : in Binding_Type;
                         Line       : in Line_Info;
                         Parent     : in Tag_Node_Access;
                         Attributes : in Tag_Attribute_Array_Access) is
   begin
      Node.Factory := Binding.Component;
      Node.Line    := Line;
      Node.Parent  := Parent;
      Node.Attributes := Attributes;
      if Node.Attributes /= null then
         for I in Attributes.all'Range loop
            Attributes (I).Tag := Node;
         end loop;
      end if;
      Append_Tag (Parent, Node);
   end Initialize;

   --  ------------------------------
   --  Append a child tag node.
   --  ------------------------------
   procedure Append_Tag (Node  : in Tag_Node_Access;
                         Child : in Tag_Node_Access) is
   begin
      if Node.First_Child = null then
         Node.First_Child := Child;
      else
         Node.Last_Child.Next := Child;
      end if;
      Node.Last_Child := Child;
      Child.Parent    := Node;
      Child.Next      := null;
   end Append_Tag;

   --  ------------------------------
   --  Freeze the tag node tree and perform any initialization steps
   --  necessary to build the components efficiently.  After this call
   --  the tag node tree should not be modified and it represents a read-only
   --  tree.
   --  ------------------------------
   procedure Freeze (Node : access Tag_Node) is
   begin
      null;
   end Freeze;

   --  ------------------------------
   --  Delete the node and its children freeing the memory as necessary
   --  ------------------------------
   procedure Delete (Node : access Tag_Node) is
      Child : Tag_Node_Access := Node.First_Child;
      Next  : Tag_Node_Access;
   begin
      while Child /= null loop
         Next := Child.Next;
         Child.Delete;
         Free (Child);
         Child := Next;
      end loop;
      if Node.Attributes /= null then
         for I in Node.Attributes'Range loop
            declare
               Expr : EL.Expressions.Expression_Access := Node.Attributes (I).Binding;
            begin
               Free (Expr);
            end;
         end loop;
         Free (Node.Attributes);
      end if;
   end Delete;

   procedure Destroy (Node : in out Tag_Node_Access) is
   begin
      Node.Delete;
      Free (Node);
   end Destroy;

   --  ------------------------------
   --  Report an error message
   --  ------------------------------
   procedure Error (Node    : in Tag_Node'Class;
                    Message : in String;
                    Param1  : in String := "";
                    Param2  : in String := "") is
      L : constant String := Node.Get_Line_Info;
   begin
      Log.Error (L & ":" & Message, Param1, Param2);
   end Error;

   --  ------------------------------
   --  Build the component attributes from the facelet tag node and the facelet context.
   --  ------------------------------
   procedure Build_Attributes (UI      : in out UIComponent'Class;
                               Node    : in Tag_Node'Class;
                               Context : in out Facelet_Context'Class) is

      procedure Process_Attribute (Attr : in Tag_Attribute_Access);

      procedure Process_Attribute (Attr : in Tag_Attribute_Access) is
      begin
         if Attr.Binding /= null then
            --  Reduce the expression by eliminating variables which are defined in
            --  the Facelet context.  We can obtain another expression or a constant value.
            declare
               Ctx  : constant EL.Contexts.ELContext_Access := Context.Get_ELContext;
               Expr : constant EL.Expressions.Expression
                 := EL.Expressions.Expression (Attr.Binding.all).Reduce_Expression (Ctx.all);
            begin
               if Expr.Is_Constant then
                  UI.Set_Attribute (Def   => Attr,
                                    Value => Expr.Get_Value (Ctx.all));
               else
                  UI.Set_Attribute (Def   => Attr,
                                    Value => Expr);
               end if;
            end;
         end if;
      end Process_Attribute;

      --  Iterate over the attributes to resolve some value expressions.
      procedure Iterate_Attributes is
        new ASF.Views.Nodes.Iterate_Attributes (Process_Attribute);
   begin
      Iterate_Attributes (Node);
   end Build_Attributes;

   --  ------------------------------
   --  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.
   --  ------------------------------
   procedure Build_Components (Node    : access Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is
      UI : constant UIComponent_Access := Node.Factory.all;
   begin
      Append (Parent, UI, Node);
      Build_Attributes (UI.all, Node.all, Context);
      UI.Initialize (UI.Get_Context.all);
      Node.Build_Children (UI, Context);
   end Build_Components;

   procedure Build_Children (Node    : access Tag_Node;
                             Parent  : in UIComponent_Access;
                             Context : in out Facelet_Context'Class) is
      Child : Tag_Node_Access;
   begin
      Child := Node.First_Child;
      while Child /= null loop
         Child.Build_Components (Parent, Context);
         Child := Child.Next;
      end loop;
   end Build_Children;

   --  ------------------------------
   --  Iterate over the attributes defined on the node and
   --  execute the <b>Process</b> procedure.
   --  ------------------------------
   procedure Iterate_Attributes (Node : in Tag_Node'Class) is
   begin
      for I in Node.Attributes'Range loop
         declare
            Attr : constant Tag_Attribute_Access := Node.Attributes (I)'Access;
         begin
            Process (Attr);
         end;
      end loop;
   end Iterate_Attributes;

   --  ------------------------------
   --  Freeze the tag node tree.
   --  Count the number of Tag_Content represented by this node.
   --  ------------------------------
   overriding
   procedure Freeze (Node : access Text_Tag_Node) is
      Content : access constant Tag_Content := Node.Content'Access;
      Count   : Natural := 0;
   begin
      loop
         Content := Content.Next;
         Count   := Count + 1;
         exit when Content = null;
      end loop;
      Node.Count := Count;
   end Freeze;

   overriding
   procedure Build_Components (Node    : access Text_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is

      UI : constant ASF.Components.Core.UIText_Access
        := ASF.Components.Core.Create_UIText (Node.all'Access);
      Expr_Table : Expression_Access_Array_Access := null;
      Ctx        : constant EL.Contexts.ELContext_Access := Context.Get_ELContext;
      Content    : access constant Tag_Content := Node.Content'Access;
      Pos        : Natural := 1;
   begin
      Append (Parent, UI.all'Access, Node);
      loop
         if not Content.Expr.Is_Null then
            --  Reduce the expression by eliminating variables which are defined in
            --  the Facelet context.  We can obtain another expression or a constant value.
            declare
               Expr : constant EL.Expressions.Expression
                 := Content.Expr.Reduce_Expression (Ctx.all);
            begin
               if Expr /= Content.Expr then
                  if Expr_Table = null then
                     Expr_Table := new Expression_Access_Array (1 .. Node.Count);
                     UI.Set_Expression_Table (Expr_Table);
                  end if;
                  Expr_Table (Pos) := new EL.Expressions.Expression '(Expr);
               end if;
            end;
         end if;

         Content := Content.Next;
         Pos     := Pos + 1;
         exit when Content = null;
      end loop;
   end Build_Components;

   --  ------------------------------
   --  Delete the node and its children freeing the memory as necessary
   --  ------------------------------
   overriding
   procedure Delete (Node : access Text_Tag_Node) is
      Content : Tag_Content_Access := Node.Content.Next;
   begin
      while Content /= null loop
         declare
            Next : constant Tag_Content_Access := Content.Next;
         begin
            Free (Content);
            Content := Next;
         end;
      end loop;
      Node.Content.Next := null;
      Node.Last := null;
   end Delete;

   --  ------------------------------
   --  Encode the content represented by this text node.
   --  The expressions are evaluated if necessary.
   --  ------------------------------
   procedure Encode_All (Node    : in Text_Tag_Node;
                         Expr    : in Expression_Access_Array_Access;
                         Context : in Faces_Context'Class) is
      Writer  : constant ASF.Contexts.Writer.Response_Writer_Access
        := Context.Get_Response_Writer;
      Content : access constant Tag_Content := Node.Content'Access;
      Pos     : Natural := 1;
   begin
      loop
         Writer.Write (Content.Text);
         begin
            if Expr /= null and then Expr (Pos) /= null then
               declare
                  Value : constant EL.Objects.Object
                    := Expr (Pos).Get_Value (Context.Get_ELContext.all);
               begin
                  if not EL.Objects.Is_Null (Value) then
                     Writer.Write_Text (Value);
                  end if;
               end;
            else
               declare
                  Value : constant EL.Objects.Object
                    := Content.Expr.Get_Value (Context.Get_ELContext.all);
               begin
                  if not EL.Objects.Is_Null (Value) then
                     Writer.Write_Text (Value);
                  end if;
               end;
            end if;

         exception
            when E : others =>
               Node.Error ("Evaluation error: {0}", Ada.Exceptions.Exception_Message (E));

         end;
         Content := Content.Next;
         Pos := Pos + 1;
         exit when Content = null;
      end loop;
   end Encode_All;

   function First (Node : in Tag_Node_Access) return Cursor is
      Result : Cursor;
   begin
      Result.Node := Node.First_Child;
      return Result;
   end First;

   function Has_Element (C : Cursor) return Boolean is
   begin
      return C.Node /= null;
   end Has_Element;

   function Element (Position : Cursor) return Tag_Node_Access is
   begin
      return Position.Node;
   end Element;

   procedure Next (Position : in out Cursor) is
   begin
      Position.Node := Position.Node.Next;
   end Next;

   --  Create a tag node
   --  Create the text Tag
   function Create_Component_Node (Binding    : in Binding_Type;
                                   Line       : in Line_Info;
                                   Parent     : in Tag_Node_Access;
                                   Attributes : in Tag_Attribute_Array_Access)
                                   return Tag_Node_Access is
      Node : constant Tag_Node_Access := new Tag_Node;
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Component_Node;

end ASF.Views.Nodes;