-----------------------------------------------------------------------
--  nodes-core -- Core nodes
--  Copyright (C) 2009, 2010 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.Transforms;
package body ASF.Views.Nodes.Core is

   --  ------------------------------
   --  Set Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Set Tag
   --  ------------------------------
   function Create_Set_Tag_Node (Name       : Unbounded_String;
                                 Line       : Line_Info;
                                 Parent     : Tag_Node_Access;
                                 Attributes : Tag_Attribute_Array_Access)
                                 return Tag_Node_Access is
      Node : constant Set_Tag_Node_Access := new Set_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Value      := Find_Attribute (Attributes, "value");
      Node.Var        := Find_Attribute (Attributes, "var");
      if Node.Value = null then
         Node.Error ("Missing 'value' attribute");
      end if;
      if Node.Var = null then
         Node.Error ("Missing 'var' attribute");
      end if;
      return Node.all'Access;
   end Create_Set_Tag_Node;

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

      Value  : constant EL.Expressions.Expression
        := Get_Expression (Node.Value.all);
   begin
      Context.Set_Variable (Node.Var.Value, Value);
   end Build_Components;

   --  ------------------------------
   --  If Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the If Tag
   --  ------------------------------
   function Create_If_Tag_Node (Name       : Unbounded_String;
                                Line       : Line_Info;
                                Parent     : Tag_Node_Access;
                                Attributes : Tag_Attribute_Array_Access)
                                return Tag_Node_Access is
      Node : constant If_Tag_Node_Access := new If_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Condition  := Find_Attribute (Attributes, "test");
      Node.Var        := Find_Attribute (Attributes, "var");
      if Node.Condition = null then
         Node.Error ("Missing 'test' attribute");
      end if;
      return Node.all'Access;
   end Create_If_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access If_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is
      Value : constant EL.Objects.Object := Get_Value (Node.Condition.all, Context);
   begin
      if Node.Var /= null then
         Context.Set_Attribute (Node.Var.Value, Value);
      end if;
      if EL.Objects.To_Boolean (Value) then
         Tag_Node (Node.all).Build_Children (Parent, Context);
      end if;
   end Build_Components;

   --  ------------------------------
   --  Choose Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Choose Tag
   --  ------------------------------
   function Create_Choose_Tag_Node (Name       : Unbounded_String;
                                    Line       : Line_Info;
                                    Parent     : Tag_Node_Access;
                                    Attributes : Tag_Attribute_Array_Access)
                                    return Tag_Node_Access is
      Node : constant Choose_Tag_Node_Access := new Choose_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Choose_Tag_Node;

   --  ------------------------------
   --  Freeze the tag node tree and perform any initialization steps
   --  necessary to build the components efficiently.
   --  Prepare the evaluation of choices by identifying the <c:when> and
   --  <c:otherwise> conditions.
   --  ------------------------------
   overriding
   procedure Freeze (Node : access Choose_Tag_Node) is
      Child  : Tag_Node_Access := Node.First_Child;
      Choice : When_Tag_Node_Access := null;
   begin
      while Child /= null loop
         if Child.all in Otherwise_Tag_Node'Class then
            Node.Otherwise := Child;

         elsif Child.all in When_Tag_Node'Class then
            if Choice = null then
               Node.Choices := When_Tag_Node (Child.all)'Access;
            else
               Choice.Next_Choice := When_Tag_Node (Child.all)'Access;
            end if;
            Choice := When_Tag_Node (Child.all)'Access;

         else
            null;
            --  @todo: report a warning in a log
            --  @todo: clean the sub-tree and remove what is not necessary
         end if;
         Child := Child.Next;
      end loop;
   end Freeze;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Choose_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is
      Choice : When_Tag_Node_Access := Node.Choices;
   begin
      --  Evaluate the choices and stop at the first which succeeds
      while Choice /= null loop
         if Choice.Is_Selected (Context) then
            Choice.Build_Children (Parent, Context);
            return;
         end if;
         Choice := Choice.Next_Choice;
      end loop;

      --  No choice matched, build the otherwise clause.
      if Node.Otherwise /= null then
         Node.Otherwise.Build_Children (Parent, Context);
      end if;
   end Build_Components;

   --  ------------------------------
   --  Create the When Tag
   --  ------------------------------
   function Create_When_Tag_Node (Name       : Unbounded_String;
                                  Line       : Line_Info;
                                  Parent     : Tag_Node_Access;
                                  Attributes : Tag_Attribute_Array_Access)
                                  return Tag_Node_Access is
      Node : constant When_Tag_Node_Access := new When_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Condition  := Find_Attribute (Attributes, "test");
      if Node.Condition = null then
         Node.Error ("Missing 'test' attribute");
      end if;
      --        Node.Var        := Find_Attribute (Attributes, "var");
      return Node.all'Access;
   end Create_When_Tag_Node;

   --  ------------------------------
   --  Check whether the node condition is selected.
   --  ------------------------------
   function Is_Selected (Node    : When_Tag_Node;
                         Context : Facelet_Context'Class) return Boolean is
   begin
      return EL.Objects.To_Boolean (Get_Value (Node.Condition.all, Context));
   end Is_Selected;

   --  ------------------------------
   --  Create the Otherwise Tag
   --  ------------------------------
   function Create_Otherwise_Tag_Node (Name       : Unbounded_String;
                                       Line       : Line_Info;
                                       Parent     : Tag_Node_Access;
                                       Attributes : Tag_Attribute_Array_Access)
                                       return Tag_Node_Access is
      Node : constant Otherwise_Tag_Node_Access := new Otherwise_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Otherwise_Tag_Node;

   --  Tag names
   CHOOSE_TAG    : aliased constant String := "choose";
   IF_TAG        : aliased constant String := "if";
   OTHERWISE_TAG : aliased constant String := "otherwise";
   SET_TAG       : aliased constant String := "set";
   WHEN_TAG      : aliased constant String := "when";

   --  Name-space URI.  Use the JSTL name-space to make the XHTML views compatible
   --  the JSF.
   URI           : aliased constant String := "http://java.sun.com/jstl/core";

   --  Tag library definition.  Names must be sorted.
   Tag_Bindings  : aliased constant ASF.Factory.Binding_Array
     := ((Name => CHOOSE_TAG'Access,
          Component => null,
          Tag => Create_Choose_Tag_Node'Access),
       (Name => IF_TAG'Access,
        Component => null,
        Tag => Create_If_Tag_Node'Access),
       (Name => OTHERWISE_TAG'Access,
        Component => null,
        Tag => Create_Otherwise_Tag_Node'Access),
       (Name => SET_TAG'Access,
        Component => null,
        Tag => Create_Set_Tag_Node'Access),
       (Name => WHEN_TAG'Access,
        Component => null,
        Tag => Create_When_Tag_Node'Access));

   Tag_Factory   : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Tag_Bindings'Access);

   --  ------------------------------
   --  Tag factory for nodes defined in this package.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Tag_Factory'Access;
   end Definition;

   --  Function names
   CAPITALIZE_FN    : aliased constant String := "capitalize";
   TO_UPPER_CASE_FN : aliased constant String := "toUpperCase";
   TO_LOWER_CASE_FN : aliased constant String := "toLowerCase";

   function Capitalize (Value : EL.Objects.Object) return EL.Objects.Object;
   function To_Upper_Case (Value : EL.Objects.Object) return EL.Objects.Object;
   function To_Lower_Case (Value : EL.Objects.Object) return EL.Objects.Object;

   function Capitalize (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.Capitalize (S));
   end Capitalize;

   function To_Upper_Case (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.To_Upper_Case (S));
   end To_Upper_Case;

   function To_Lower_Case (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.To_Lower_Case (S));
   end To_Lower_Case;

   --  ------------------------------
   --  Register a set of functions in the namespace
   --  xmlns:fn="http://java.sun.com/jsp/jstl/functions"
   --  Functions:
   --    capitalize, toUpperCase, toLowerCase
   --  ------------------------------
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
      URI : constant String := "http://java.sun.com/jsp/jstl/functions";
   begin
      Mapper.Set_Function (Name      => CAPITALIZE_FN,
                           Namespace => URI,
                           Func      => Capitalize'Access);
      Mapper.Set_Function (Name      => TO_LOWER_CASE_FN,
                           Namespace => URI,
                           Func      => To_Lower_Case'Access);
      Mapper.Set_Function (Name      => TO_UPPER_CASE_FN,
                           Namespace => URI,
                           Func      => To_Upper_Case'Access);
   end Set_Functions;

end ASF.Views.Nodes.Core;

-----------------------------------------------------------------------
--  nodes-core -- Core nodes
--  Copyright (C) 2009, 2010 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.Transforms;
with Ada.Strings.Fixed;
package body ASF.Views.Nodes.Core is

   --  ------------------------------
   --  Set Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Set Tag
   --  ------------------------------
   function Create_Set_Tag_Node (Name       : Unbounded_String;
                                 Line       : Line_Info;
                                 Parent     : Tag_Node_Access;
                                 Attributes : Tag_Attribute_Array_Access)
                                 return Tag_Node_Access is
      Node : constant Set_Tag_Node_Access := new Set_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Value      := Find_Attribute (Attributes, "value");
      Node.Var        := Find_Attribute (Attributes, "var");
      if Node.Value = null then
         Node.Error ("Missing 'value' attribute");
      end if;
      if Node.Var = null then
         Node.Error ("Missing 'var' attribute");
      end if;
      return Node.all'Access;
   end Create_Set_Tag_Node;

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

      Value  : constant EL.Expressions.Expression
        := Get_Expression (Node.Value.all);
   begin
      Context.Set_Variable (Node.Var.Value, Value);
   end Build_Components;

   --  ------------------------------
   --  If Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the If Tag
   --  ------------------------------
   function Create_If_Tag_Node (Name       : Unbounded_String;
                                Line       : Line_Info;
                                Parent     : Tag_Node_Access;
                                Attributes : Tag_Attribute_Array_Access)
                                return Tag_Node_Access is
      Node : constant If_Tag_Node_Access := new If_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Condition  := Find_Attribute (Attributes, "test");
      Node.Var        := Find_Attribute (Attributes, "var");
      if Node.Condition = null then
         Node.Error ("Missing 'test' attribute");
      end if;
      return Node.all'Access;
   end Create_If_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access If_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is
      Value : constant EL.Objects.Object := Get_Value (Node.Condition.all, Context);
   begin
      if Node.Var /= null then
         Context.Set_Attribute (Node.Var.Value, Value);
      end if;
      if EL.Objects.To_Boolean (Value) then
         Tag_Node (Node.all).Build_Children (Parent, Context);
      end if;
   end Build_Components;

   --  ------------------------------
   --  Choose Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Choose Tag
   --  ------------------------------
   function Create_Choose_Tag_Node (Name       : Unbounded_String;
                                    Line       : Line_Info;
                                    Parent     : Tag_Node_Access;
                                    Attributes : Tag_Attribute_Array_Access)
                                    return Tag_Node_Access is
      Node : constant Choose_Tag_Node_Access := new Choose_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Choose_Tag_Node;

   --  ------------------------------
   --  Freeze the tag node tree and perform any initialization steps
   --  necessary to build the components efficiently.
   --  Prepare the evaluation of choices by identifying the <c:when> and
   --  <c:otherwise> conditions.
   --  ------------------------------
   overriding
   procedure Freeze (Node : access Choose_Tag_Node) is
      Child  : Tag_Node_Access := Node.First_Child;
      Choice : When_Tag_Node_Access := null;
   begin
      while Child /= null loop
         if Child.all in Otherwise_Tag_Node'Class then
            Node.Otherwise := Child;

         elsif Child.all in When_Tag_Node'Class then
            if Choice = null then
               Node.Choices := When_Tag_Node (Child.all)'Access;
            else
               Choice.Next_Choice := When_Tag_Node (Child.all)'Access;
            end if;
            Choice := When_Tag_Node (Child.all)'Access;

         else
            null;
            --  @todo: report a warning in a log
            --  @todo: clean the sub-tree and remove what is not necessary
         end if;
         Child := Child.Next;
      end loop;
   end Freeze;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Choose_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Facelet_Context'Class) is
      Choice : When_Tag_Node_Access := Node.Choices;
   begin
      --  Evaluate the choices and stop at the first which succeeds
      while Choice /= null loop
         if Choice.Is_Selected (Context) then
            Choice.Build_Children (Parent, Context);
            return;
         end if;
         Choice := Choice.Next_Choice;
      end loop;

      --  No choice matched, build the otherwise clause.
      if Node.Otherwise /= null then
         Node.Otherwise.Build_Children (Parent, Context);
      end if;
   end Build_Components;

   --  ------------------------------
   --  Create the When Tag
   --  ------------------------------
   function Create_When_Tag_Node (Name       : Unbounded_String;
                                  Line       : Line_Info;
                                  Parent     : Tag_Node_Access;
                                  Attributes : Tag_Attribute_Array_Access)
                                  return Tag_Node_Access is
      Node : constant When_Tag_Node_Access := new When_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Condition  := Find_Attribute (Attributes, "test");
      if Node.Condition = null then
         Node.Error ("Missing 'test' attribute");
      end if;
      --        Node.Var        := Find_Attribute (Attributes, "var");
      return Node.all'Access;
   end Create_When_Tag_Node;

   --  ------------------------------
   --  Check whether the node condition is selected.
   --  ------------------------------
   function Is_Selected (Node    : When_Tag_Node;
                         Context : Facelet_Context'Class) return Boolean is
   begin
      return EL.Objects.To_Boolean (Get_Value (Node.Condition.all, Context));
   end Is_Selected;

   --  ------------------------------
   --  Create the Otherwise Tag
   --  ------------------------------
   function Create_Otherwise_Tag_Node (Name       : Unbounded_String;
                                       Line       : Line_Info;
                                       Parent     : Tag_Node_Access;
                                       Attributes : Tag_Attribute_Array_Access)
                                       return Tag_Node_Access is
      Node : constant Otherwise_Tag_Node_Access := new Otherwise_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Otherwise_Tag_Node;

   --  Tag names
   CHOOSE_TAG    : aliased constant String := "choose";
   IF_TAG        : aliased constant String := "if";
   OTHERWISE_TAG : aliased constant String := "otherwise";
   SET_TAG       : aliased constant String := "set";
   WHEN_TAG      : aliased constant String := "when";

   --  Name-space URI.  Use the JSTL name-space to make the XHTML views compatible
   --  the JSF.
   URI           : aliased constant String := "http://java.sun.com/jstl/core";

   --  Tag library definition.  Names must be sorted.
   Tag_Bindings  : aliased constant ASF.Factory.Binding_Array
     := ((Name => CHOOSE_TAG'Access,
          Component => null,
          Tag => Create_Choose_Tag_Node'Access),
       (Name => IF_TAG'Access,
        Component => null,
        Tag => Create_If_Tag_Node'Access),
       (Name => OTHERWISE_TAG'Access,
        Component => null,
        Tag => Create_Otherwise_Tag_Node'Access),
       (Name => SET_TAG'Access,
        Component => null,
        Tag => Create_Set_Tag_Node'Access),
       (Name => WHEN_TAG'Access,
        Component => null,
        Tag => Create_When_Tag_Node'Access));

   Tag_Factory   : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Tag_Bindings'Access);

   --  ------------------------------
   --  Tag factory for nodes defined in this package.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Tag_Factory'Access;
   end Definition;

   --  Function names
   CAPITALIZE_FN       : aliased constant String := "capitalize";
   TO_UPPER_CASE_FN    : aliased constant String := "toUpperCase";
   TO_LOWER_CASE_FN    : aliased constant String := "toLowerCase";
   SUBSTRING_AFTER_FN  : aliased constant String := "substringAfter";
   SUBSTRING_BEFORE_FN : aliased constant String := "substringBefore";

   function Capitalize (Value : EL.Objects.Object) return EL.Objects.Object;
   function To_Upper_Case (Value : EL.Objects.Object) return EL.Objects.Object;
   function To_Lower_Case (Value : EL.Objects.Object) return EL.Objects.Object;
   function Substring_Before (Value : in EL.Objects.Object;
                              Token : in EL.Objects.Object) return EL.Objects.Object;
   function Substring_After (Value : in EL.Objects.Object;
                             Token : in EL.Objects.Object) return EL.Objects.Object;

   function Capitalize (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.Capitalize (S));
   end Capitalize;

   function To_Upper_Case (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.To_Upper_Case (S));
   end To_Upper_Case;

   function To_Lower_Case (Value : EL.Objects.Object) return EL.Objects.Object is
      S : constant String := EL.Objects.To_String (Value);
   begin
      return EL.Objects.To_Object (Util.Strings.Transforms.To_Lower_Case (S));
   end To_Lower_Case;

   --  ------------------------------
   --  Return the substring before the token string
   --  ------------------------------
   function Substring_Before (Value : in EL.Objects.Object;
                              Token : in EL.Objects.Object) return EL.Objects.Object is
      S   : constant String := EL.Objects.To_String (Value);
      T   : constant String := EL.Objects.To_String (Token);
      Pos : constant Natural := Ada.Strings.Fixed.Index (S, T);
   begin
      if Pos = 0 then
         return EL.Objects.Null_Object;
      else
         return EL.Objects.To_Object (S (S'First .. Pos - 1));
      end if;
   end Substring_Before;

   --  ------------------------------
   --  Return the substring after the token string
   --  ------------------------------
   function Substring_After (Value : in EL.Objects.Object;
                              Token : in EL.Objects.Object) return EL.Objects.Object is
      S   : constant String := EL.Objects.To_String (Value);
      T   : constant String := EL.Objects.To_String (Token);
      Pos : constant Natural := Ada.Strings.Fixed.Index (S, T);
   begin
      if Pos = 0 then
         return EL.Objects.Null_Object;
      else
         return EL.Objects.To_Object (S (Pos + T'Length .. S'Last));
      end if;
   end Substring_After;

   --  ------------------------------
   --  Register a set of functions in the namespace
   --  xmlns:fn="http://java.sun.com/jsp/jstl/functions"
   --  Functions:
   --    capitalize, toUpperCase, toLowerCase
   --  ------------------------------
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
      URI : constant String := "http://java.sun.com/jsp/jstl/functions";
   begin
      Mapper.Set_Function (Name      => CAPITALIZE_FN,
                           Namespace => URI,
                           Func      => Capitalize'Access);
      Mapper.Set_Function (Name      => TO_LOWER_CASE_FN,
                           Namespace => URI,
                           Func      => To_Lower_Case'Access);
      Mapper.Set_Function (Name      => TO_UPPER_CASE_FN,
                           Namespace => URI,
                           Func      => To_Upper_Case'Access);
      Mapper.Set_Function (Name      => SUBSTRING_BEFORE_FN,
                           Namespace => URI,
                           Func      => Substring_Before'Access);
      Mapper.Set_Function (Name      => SUBSTRING_AFTER_FN,
                           Namespace => URI,
                           Func      => Substring_After'Access);
   end Set_Functions;

end ASF.Views.Nodes.Core;

Add substring before and substring after EL functions


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

with Util.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

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

   type Test is new Util.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

   --  Test listing the blog posts.
   procedure Test_Admin_List_Posts (T : in out Test);

   --  Test listing the blog comments.
   procedure Test_Admin_List_Comments (T : in out Test);

   --  Test getting the JSON blog stats (for graphs).
   procedure Test_Admin_Blog_Stats (T : in out Test);

end AWA.Blogs.Tests;

-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 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 Util.Tests;
with AWA.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

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

   type Test is new AWA.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

   --  Test listing the blog posts.
   procedure Test_Admin_List_Posts (T : in out Test);

   --  Test listing the blog comments.
   procedure Test_Admin_List_Comments (T : in out Test);

   --  Test getting the JSON blog stats (for graphs).
   procedure Test_Admin_Blog_Stats (T : in out Test);

end AWA.Blogs.Tests;

Update the test declaration to use AWA.Tests.Test type


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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO;
with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

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

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      declare
         Ctx     : EL.Contexts.Default.Default_Context;
         Command : constant String := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
      begin
         Service.Thumbnail_Command := EL.Expressions.Create_Expression (Command, Ctx);

      exception
         when E : others =>
            Log.Error ("Invalid thumbnail command: ", E, True);
      end;
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier;
                              File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (File);

      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Width       : Natural;
      Height      : Natural;
   begin
      Img.Load (DB, Id);
      Storage_Service.Get_Local_File (From => Img.Get_Storage.Get_Id, Into => Local_File);
      Storage_Service.Create_Local_File (Target_File);
      Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                AWA.Storages.Get_Path (Target_File), Width, Height);
      Img.Set_Width (Width);
      Img.Set_Height (Height);
      Img.Set_Thumb_Width (64);
      Img.Set_Thumb_Height (64);
      Ctx.Start;
      Img.Save (DB);
--        Storage_Service.Save (Target_File);
      Ctx.Commit;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO;
with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

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

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      Service.Thumbnail_Command := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier;
                              File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (File);

      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Width       : Natural;
      Height      : Natural;
   begin
      Img.Load (DB, Id);
      Storage_Service.Get_Local_File (From => Img.Get_Storage.Get_Id, Into => Local_File);
      Storage_Service.Create_Local_File (Target_File);
      Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                AWA.Storages.Get_Path (Target_File), Width, Height);
      Img.Set_Width (Width);
      Img.Set_Height (Height);
      Img.Set_Thumb_Width (64);
      Img.Set_Thumb_Height (64);
      Ctx.Start;
      Img.Save (DB);
--        Storage_Service.Save (Target_File);
      Ctx.Commit;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

Use the Get_Config procedure that returns an EL expression to get the thumbnail command


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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Maps;

with ADO.Sessions;

with AWA.Events;
with AWA.Jobs.Models;

package AWA.Jobs.Services is

   Closed_Error   : exception;

   Schedule_Error : exception;

   Execute_Error  : exception;

   Invalid_Value  : exception;

   --  Event posted when a job is created.
   package Job_Create_Event is new AWA.Events.Definition (Name => "job-create");

   --  Get the job status.
   function Get_Job_Status (Id : in ADO.Identifier) return AWA.Jobs.Models.Job_Status_Type;

   --  ------------------------------
   --  Abstract_Job Type
   --  ------------------------------
   --  The Abstract_Job_Type is an abstract tagged record which defines a job that can be
   --  scheduled and executed.
   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Abstract_Job_Access is access all Abstract_Job_Type'Class;

   --  Execute the job.  This operation must be implemented and should perform the work
   --  represented by the job.  It should use the <tt>Get_Parameter</tt> function to retrieve
   --  the job parameter and it can use the <tt>Set_Result</tt> operation to save the result.
   procedure Execute (Job : in out Abstract_Job_Type) is abstract;

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String);

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer);

   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object);

   --  Get the job parameter identified by the Name and convert the value into a string.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String;

   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer;

   --  Get the job parameter identified by the Name and return it as a typed object.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object;

   --  Get the job status.
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type;

   --  Get the job identifier once the job was scheduled.  The job identifier allows to
   --  retrieve the job and check its execution and completion status later on.
   function Get_Identifier (Job : in Abstract_Job_Type) return ADO.Identifier;

   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type);

   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class);

   --  ------------------------------
   --  Job Factory
   --  ------------------------------
   --  The Job_Factory is the interface that allows to create a job instance in order
   --  to execute a scheduled job.
   type Job_Factory is abstract tagged limited null record;
   type Job_Factory_Access is access all Job_Factory'Class;

   --  Create the job instance using the job factory.
   function Create (Factory : in Job_Factory) return Abstract_Job_Access is abstract;

   --  Get the job factory name.
   function Get_Name (Factory : in Job_Factory'Class) return String;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class);

   --  ------------------------------
   --  Work Factory
   --  ------------------------------
   type Work_Access is access procedure (Job : in out Abstract_Job_Type'Class);

   type Work_Factory (Work : Work_Access) is new Job_Factory with null record;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access;

   --  ------------------------------
   --
   --  ------------------------------
   type Job_Type is new Abstract_Job_Type with private;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class);

   procedure Execute (Job : in out Job_Type);

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   generic
      type T is new Abstract_Job_Type with private;
   package Definition is
      type Job_Type_Factory is new Job_Factory with null record;

      overriding
      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access;

      Factory : aliased Job_Type_Factory;

   end Definition;

   generic
      Work : in Work_Access;
   package Work_Definition is
      type S_Factory is new Work_Factory with null record;

      Factory : aliased S_Factory := S_Factory '(Work => Work);
   end Work_Definition;

   --  Execute the job associated with the given event.
   procedure Execute (Event : in AWA.Events.Module_Event'Class);

private

   --  Execute the job and save the job information in the database.
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class);

   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Job              : AWA.Jobs.Models.Job_Ref;
      Props            : Util.Beans.Objects.Maps.Map;
      Results          : Util.Beans.Objects.Maps.Map;
      Props_Modified   : Boolean := False;
      Results_Modified : Boolean := False;
   end record;

   type Job_Type is new Abstract_Job_Type with record
      Work : Work_Access;
   end record;

end AWA.Jobs.Services;

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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Maps;

with ADO.Sessions;

with AWA.Events;
with AWA.Jobs.Models;

package AWA.Jobs.Services is

   Closed_Error   : exception;

   Schedule_Error : exception;

   Execute_Error  : exception;

   Invalid_Value  : exception;

   --  Event posted when a job is created.
   package Job_Create_Event is new AWA.Events.Definition (Name => "job-create");

   --  Get the job status.
   function Get_Job_Status (Id : in ADO.Identifier) return AWA.Jobs.Models.Job_Status_Type;

   --  ------------------------------
   --  Abstract_Job Type
   --  ------------------------------
   --  The Abstract_Job_Type is an abstract tagged record which defines a job that can be
   --  scheduled and executed.
   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Abstract_Job_Access is access all Abstract_Job_Type'Class;

   --  Execute the job.  This operation must be implemented and should perform the work
   --  represented by the job.  It should use the <tt>Get_Parameter</tt> function to retrieve
   --  the job parameter and it can use the <tt>Set_Result</tt> operation to save the result.
   procedure Execute (Job : in out Abstract_Job_Type) is abstract;

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String);

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer);

   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object);

   --  Get the job parameter identified by the Name and convert the value into a string.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String;

   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer;

   --  Get the job parameter identified by the Name and return it as a typed object.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object;

   --  Get the job status.
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type;

   --  Get the job identifier once the job was scheduled.  The job identifier allows to
   --  retrieve the job and check its execution and completion status later on.
   function Get_Identifier (Job : in Abstract_Job_Type) return ADO.Identifier;

   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type);

   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class);

   --  ------------------------------
   --  Job Factory
   --  ------------------------------
   --  The Job_Factory is the interface that allows to create a job instance in order
   --  to execute a scheduled job.
   type Job_Factory is abstract tagged limited null record;
   type Job_Factory_Access is access all Job_Factory'Class;

   --  Create the job instance using the job factory.
   function Create (Factory : in Job_Factory) return Abstract_Job_Access is abstract;

   --  Get the job factory name.
   function Get_Name (Factory : in Job_Factory'Class) return String;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class);

   --  ------------------------------
   --  Work Factory
   --  ------------------------------
   type Work_Access is access procedure (Job : in out Abstract_Job_Type'Class);

   type Work_Factory (Work : Work_Access) is new Job_Factory with null record;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access;

   --  ------------------------------
   --
   --  ------------------------------
   type Job_Type is new Abstract_Job_Type with private;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class);

   procedure Execute (Job : in out Job_Type);

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   generic
      type T is new Abstract_Job_Type with private;
   package Definition is
      type Job_Type_Factory is new Job_Factory with null record;

      overriding
      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access;

      --  The job factory.
      Factory : constant Job_Factory_Access;

   private
      Instance : aliased Job_Type_Factory;
      Factory  : constant Job_Factory_Access := Instance'Access;
   end Definition;

   generic
      Work : in Work_Access;
   package Work_Definition is
      type S_Factory is new Work_Factory with null record;

      --  The job factory.
      Factory : constant Job_Factory_Access;
   private
      Instance : aliased S_Factory := S_Factory '(Work => Work);
      Factory  : constant Job_Factory_Access := Instance'Access;
   end Work_Definition;

   --  Execute the job associated with the given event.
   procedure Execute (Event : in AWA.Events.Module_Event'Class);

private

   --  Execute the job and save the job information in the database.
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class);

   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Job              : AWA.Jobs.Models.Job_Ref;
      Props            : Util.Beans.Objects.Maps.Map;
      Results          : Util.Beans.Objects.Maps.Map;
      Props_Modified   : Boolean := False;
      Results_Modified : Boolean := False;
   end record;

   type Job_Type is new Abstract_Job_Type with record
      Work : Work_Access;
   end record;

end AWA.Jobs.Services;

Simplify the use of the job factory

Simplify the use of the job factory


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 onox <denkpadje@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.

private with Ada.Containers.Indefinite_Holders;

with GL.Buffers;
with GL.Objects.Framebuffers;
with GL.Objects.Textures;
with GL.Types.Colors;

with Orka.Contexts;
with Orka.Rendering.Buffers;
with Orka.Rendering.Textures;
with Orka.Windows;

package Orka.Rendering.Framebuffers is
   pragma Preelaborate;

   use GL.Types;

   package FB renames GL.Objects.Framebuffers;
   package Textures renames GL.Objects.Textures;

   subtype Color_Attachment_Point is FB.Attachment_Point
     range FB.Color_Attachment_0 .. FB.Color_Attachment_15;

   type Use_Point_Array is array (Rendering.Framebuffers.Color_Attachment_Point) of Boolean;
   --  TODO Use as formal parameter in procedure Invalidate

   type Buffer_Values is record
      Color   : Colors.Color             := (0.0, 0.0, 0.0, 0.0);
      Depth   : GL.Buffers.Depth         := 1.0;
      Stencil : GL.Buffers.Stencil_Index := 0;
   end record;

   type Framebuffer
     (Default : Boolean;
      Width, Height, Samples : Size) is tagged private
   with Type_Invariant => (if Framebuffer.Default then Framebuffer.Samples = 0);

   type Framebuffer_Ptr is not null access Framebuffer;

   function Create_Framebuffer
     (Width, Height, Samples : Size;
      Context : Contexts.Context'Class) return Framebuffer
   with Pre  => (if Samples > 0 then Context.Enabled (Contexts.Multisample)),
        Post => not Create_Framebuffer'Result.Default;

   function Create_Framebuffer (Width, Height : Size) return Framebuffer
     with Post => not Create_Framebuffer'Result.Default;

   -----------------------------------------------------------------------------

   function Get_Default_Framebuffer
     (Window : Orka.Windows.Window'Class) return Framebuffer
   with Post => Get_Default_Framebuffer'Result.Default;

   function Create_Default_Framebuffer
     (Width, Height : Size) return Framebuffer
   with Post => Create_Default_Framebuffer'Result.Default;

   -----------------------------------------------------------------------------

   function GL_Framebuffer (Object : Framebuffer) return FB.Framebuffer
     with Inline;

   -----------------------------------------------------------------------------

   function Image (Object : Framebuffer) return String;
   --  Return a description of the given framebuffer

   procedure Use_Framebuffer (Object : Framebuffer);
   --  Use the framebuffer during rendering
   --
   --  The viewport is adjusted to the size of the framebuffer.

   procedure Set_Default_Values (Object : in out Framebuffer; Values : Buffer_Values);
   --  Set the default values for the color buffers and depth and stencil
   --  buffers

   function Default_Values (Object : Framebuffer) return Buffer_Values;
   --  Return the current default values used when clearing the attached
   --  textures

   procedure Set_Read_Buffer
     (Object : Framebuffer;
      Buffer : GL.Buffers.Color_Buffer_Selector);
   --  Set the buffer to use when blitting to another framebuffer with
   --  procedure Resolve_To

   procedure Set_Draw_Buffers
     (Object  : in out Framebuffer;
      Buffers : GL.Buffers.Color_Buffer_List);
   --  Set the buffers to use when drawing to output variables in a fragment
   --  shader, when calling procedure Clear, or when another framebuffer
   --  blits its read buffer to this framebuffer with procedure Resolve_To

   procedure Clear
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits := (others => True));
   --  Clear the attached textures for which the mask is True using
   --  the default values set with Set_Default_Values
   --
   --  For clearing to be effective, the following conditions must apply:
   --
   --    - Write mask off
   --    - Rasterizer discard disabled
   --    - Scissor test off or scissor rectangle set to the desired region
   --    - Called procedure Set_Draw_Buffers with a list of attachments
   --
   --  If a combined depth/stencil texture has been attached, the depth
   --  and stencil components can be cleared separately, but it may be
   --  faster to clear both components.

   procedure Invalidate
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits);
   --  Invalidate the attached textures for which the mask is True

   procedure Resolve_To
     (Object, Subject : Framebuffer;
      Mask : GL.Buffers.Buffer_Bits := (Color => True, others => False))
   with Pre => Object /= Subject and
                 (Mask.Color or Mask.Depth or Mask.Stencil) and
                 (if Object.Samples > 0 and Subject.Samples > 0 then
                    Object.Samples = Subject.Samples);
   --  Copy one or more buffers, resolving multiple samples and scaling
   --  if necessary, from the source to the destination framebuffer
   --
   --  If a buffer is specified in the mask, then the buffer should exist
   --  in both framebuffers, otherwise the buffer is not copied. Call
   --  Set_Read_Buffer and Set_Draw_Buffers to control which buffer is read
   --  from and which buffers are written to.
   --
   --  Format of color buffers may differ and will be converted (if
   --  supported). Formats of depth and stencil buffers must match.
   --
   --  Note: simultaneously resolving multiple samples and scaling
   --  requires GL_EXT_framebuffer_multisample_blit_scaled.

   procedure Attach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.

   procedure Attach
     (Object  : in out Framebuffer;
      Texture : Textures.Texture;
      Level   : Textures.Mipmap_Level := 0);
   --  Attach the texture to an attachment point based on the internal
   --  format of the texture
   --
   --  Internally calls the procedure Attach above.
   --
   --  If the texture is color renderable, it will always be attached to
   --  Color_Attachment_0. If you need to attach a texture to a different
   --  color attachment point then use the other procedure Attach directly.
   --
   --  If the texture is layered and you want to attach a specific layer,
   --  then you must call the procedure Attach_Layer below instead.

   procedure Attach_Layer
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Layer      : Natural;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  Texture.Layered and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach layer of " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the selected 1D/2D layer of the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.
   --
   --  The texture must be layered (3D, 1D/2D array, cube
   --  map [array], or 2D multisampled array).

   procedure Detach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point)
   with Pre  => not Object.Default,
        Post => not Object.Has_Attachment (Attachment);
   --  Detach any texture currently attached to the given attachment point

   function Has_Attachment
     (Object     : Framebuffer;
      Attachment : FB.Attachment_Point) return Boolean;

   Framebuffer_Incomplete_Error : exception;

private

   package Attachment_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Textures.Texture, "=" => Textures."=");

   package Color_Buffer_List_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Buffers.Color_Buffer_List, "=" => GL.Buffers."=");

   type Attachment_Array is array (FB.Attachment_Point)
     of Attachment_Holder.Holder;

   type Framebuffer (Default : Boolean; Width, Height, Samples : Size) is tagged record
      GL_Framebuffer : FB.Framebuffer;
      Attachments    : Attachment_Array;
      Defaults       : Buffer_Values;
      Draw_Buffers   : Color_Buffer_List_Holder.Holder;
   end record;

end Orka.Rendering.Framebuffers;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 onox <denkpadje@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.

private with Ada.Containers.Indefinite_Holders;

with GL.Buffers;
with GL.Objects.Framebuffers;
with GL.Objects.Textures;
with GL.Types.Colors;

with Orka.Contexts;
with Orka.Rendering.Buffers;
with Orka.Rendering.Textures;
with Orka.Windows;

package Orka.Rendering.Framebuffers is
   pragma Preelaborate;

   use GL.Types;

   package FB renames GL.Objects.Framebuffers;
   package Textures renames GL.Objects.Textures;

   subtype Color_Attachment_Point is FB.Attachment_Point
     range FB.Color_Attachment_0 .. FB.Color_Attachment_15;

   type Use_Point_Array is array (Rendering.Framebuffers.Color_Attachment_Point) of Boolean;
   --  TODO Use as formal parameter in procedure Invalidate

   type Buffer_Values is record
      Color   : Colors.Color             := (0.0, 0.0, 0.0, 0.0);
      Depth   : GL.Buffers.Depth         := 1.0;
      Stencil : GL.Buffers.Stencil_Index := 0;
   end record;

   type Framebuffer
     (Default : Boolean;
      Width, Height, Samples : Size) is tagged private
   with Type_Invariant => (if Framebuffer.Default then Framebuffer.Samples = 0);

   type Framebuffer_Ptr is not null access Framebuffer;

   function Create_Framebuffer
     (Width, Height, Samples : Size;
      Context : Contexts.Context'Class) return Framebuffer
   with Pre  => (if Samples > 0 then Context.Enabled (Contexts.Multisample)),
        Post => not Create_Framebuffer'Result.Default;

   function Create_Framebuffer (Width, Height : Size) return Framebuffer
     with Post => not Create_Framebuffer'Result.Default;

   -----------------------------------------------------------------------------

   function Get_Default_Framebuffer
     (Window : Orka.Windows.Window'Class) return Framebuffer
   with Post => Get_Default_Framebuffer'Result.Default;

   function Create_Default_Framebuffer
     (Width, Height : Size) return Framebuffer
   with Post => Create_Default_Framebuffer'Result.Default;

   -----------------------------------------------------------------------------

   function GL_Framebuffer (Object : Framebuffer) return FB.Framebuffer
     with Inline;

   -----------------------------------------------------------------------------

   function Image (Object : Framebuffer) return String;
   --  Return a description of the given framebuffer

   procedure Use_Framebuffer (Object : Framebuffer);
   --  Use the framebuffer during rendering
   --
   --  The viewport is adjusted to the size of the framebuffer.

   procedure Set_Default_Values (Object : in out Framebuffer; Values : Buffer_Values);
   --  Set the default values for the color buffers and depth and stencil
   --  buffers

   function Default_Values (Object : Framebuffer) return Buffer_Values;
   --  Return the current default values used when clearing the attached
   --  textures

   procedure Set_Read_Buffer
     (Object : Framebuffer;
      Buffer : GL.Buffers.Color_Buffer_Selector);
   --  Set the buffer to use when blitting to another framebuffer with
   --  procedure Resolve_To

   procedure Set_Draw_Buffers
     (Object  : in out Framebuffer;
      Buffers : GL.Buffers.Color_Buffer_List);
   --  Set the buffers to use when drawing to output variables in a fragment
   --  shader, when calling procedure Clear, or when another framebuffer
   --  blits its read buffer to this framebuffer with procedure Resolve_To

   procedure Clear
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits := (others => True));
   --  Clear the attached textures for which the mask is True using
   --  the default values set with Set_Default_Values
   --
   --  For clearing to be effective, the following conditions must apply:
   --
   --    - Write mask off
   --    - Rasterizer discard disabled
   --    - Scissor test off or scissor rectangle set to the desired region
   --    - Called procedure Set_Draw_Buffers with a list of attachments
   --
   --  If a combined depth/stencil texture has been attached, the depth
   --  and stencil components can be cleared separately, but it may be
   --  faster to clear both components.

   procedure Invalidate
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits);
   --  Invalidate the attached textures for which the mask is True

   procedure Resolve_To
     (Object, Subject : Framebuffer;
      Mask : GL.Buffers.Buffer_Bits := (Color => True, others => False))
   with Pre => Object /= Subject and
                 (Mask.Color or Mask.Depth or Mask.Stencil) and
                 (if Object.Samples > 0 and Subject.Samples > 0 then
                    Object.Samples = Subject.Samples);
   --  Copy one or more buffers, resolving multiple samples and scaling
   --  if necessary, from the source to the destination framebuffer
   --
   --  If a buffer is specified in the mask, then the buffer should exist
   --  in both framebuffers, otherwise the buffer is not copied. Call
   --  Set_Read_Buffer and Set_Draw_Buffers to control which buffer is read
   --  from and which buffers are written to.
   --
   --  Format of color buffers may differ and will be converted (if
   --  supported). Formats of depth and stencil buffers must match.
   --
   --  Note: simultaneously resolving multiple samples and scaling
   --  requires GL_EXT_framebuffer_multisample_blit_scaled.

   procedure Attach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.
   --
   --  If one of the attached textures is layered (3D, 1D/2D array, cube
   --  map [array], or 2D multisampled array), then all attachments must
   --  have the same kind.
   --
   --  All attachments of the framebuffer must have the same amount of
   --  samples and they must all have fixed sample locations, or none of
   --  them must have them.

   procedure Attach
     (Object  : in out Framebuffer;
      Texture : Textures.Texture;
      Level   : Textures.Mipmap_Level := 0);
   --  Attach the texture to an attachment point based on the internal
   --  format of the texture
   --
   --  Internally calls the procedure Attach above.
   --
   --  If the texture is color renderable, it will always be attached to
   --  Color_Attachment_0. If you need to attach a texture to a different
   --  color attachment point then use the other procedure Attach directly.
   --
   --  If the texture is layered and you want to attach a specific layer,
   --  then you must call the procedure Attach_Layer below instead.

   procedure Attach_Layer
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Layer      : Natural;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  Texture.Layered and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach layer of " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the selected 1D/2D layer of the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.
   --
   --  The texture must be layered (3D, 1D/2D array, cube
   --  map [array], or 2D multisampled array).

   procedure Detach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point)
   with Pre  => not Object.Default,
        Post => not Object.Has_Attachment (Attachment);
   --  Detach any texture currently attached to the given attachment point

   function Has_Attachment
     (Object     : Framebuffer;
      Attachment : FB.Attachment_Point) return Boolean;

   Framebuffer_Incomplete_Error : exception;

private

   package Attachment_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Textures.Texture, "=" => Textures."=");

   package Color_Buffer_List_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Buffers.Color_Buffer_List, "=" => GL.Buffers."=");

   type Attachment_Array is array (FB.Attachment_Point)
     of Attachment_Holder.Holder;

   type Framebuffer (Default : Boolean; Width, Height, Samples : Size) is tagged record
      GL_Framebuffer : FB.Framebuffer;
      Attachments    : Attachment_Array;
      Defaults       : Buffer_Values;
      Draw_Buffers   : Color_Buffer_List_Holder.Holder;
   end record;

end Orka.Rendering.Framebuffers;

orka: Document some framebuffer completion requirements for Attach

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  asf-views -- Views
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Path         : String (1 .. Length);
      Relative_Pos : Natural;
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

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

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Relative_Pos : Natural;
      Path         : String (1 .. Length);
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

Reorder the File_Info record

Reorder the File_Info record