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

with Ada.Strings.Unbounded;

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

with EL.Objects;
with EL.Expressions;
with EL.Contexts.Default;
with EL.Contexts.Properties;
package body EL.Utils is

   use Ada.Strings.Unbounded;
   use Util.Beans.Objects;

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

   --  ------------------------------
   --  Expand the properties stored in Source by evaluating the EL expressions
   --  used in the property values.  The EL context passed in Context can be used
   --  to specify the EL functions or some pre-defined beans that could be used.
   --  The EL context will integrate the source properties as well as properties stored
   --  in Into (only the Source properties will be evaluated).
   --  ------------------------------
   procedure Expand (Source  : in Util.Properties.Manager'Class;
                     Into    : in out Util.Properties.Manager'Class;
                     Context : in EL.Contexts.ELContext'Class) is

      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object;

      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      procedure Process (Name : in String;
                         Item : in Util.Beans.Objects.Object);

      type Local_Resolver is new EL.Contexts.Properties.Property_Resolver with null record;

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

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object is
         pragma Unreferenced (Resolver);
      begin
         if Base /= null then
            return Base.Get_Value (To_String (Name));

         elsif Into.Exists (Name) then
            declare
               Value  : constant String := Into.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         elsif Source.Exists (Name) then
            declare
               Value  : constant String := Source.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end Get_Value;

      Recursion : Natural := 10;

      --  ------------------------------
      --  Expand (recursively) the EL expression defined in Value by using
      --  the context.  The recursion is provided by the above context resolver which
      --  invokes Expand if it detects that a value is a possible EL expression.
      --  ------------------------------
      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object is
         Expr   : EL.Expressions.Expression;
         Result : Util.Beans.Objects.Object;
      begin
         if Recursion = 0 then
            Log.Error ("Too many level of recursion when evaluating expression: {0}", Value);
            return Util.Beans.Objects.Null_Object;
         end if;

         Recursion := Recursion - 1;
         Expr := EL.Expressions.Create_Expression (Value, Context);
         Result := Expr.Get_Value (Context);
         Recursion := Recursion + 1;
         return Result;

         --  Ignore any exception and copy the value verbatim.
      exception
         when others =>
            Recursion := Recursion + 1;
            return Util.Beans.Objects.To_Object (Value);
      end Expand;

      Resolver       : aliased Local_Resolver;
      Local_Context  : aliased EL.Contexts.Default.Default_Context;

      --  ------------------------------
      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      --  ------------------------------
      procedure Process (Name : in String;
                         Item : in Util.Properties.Value) is
         use Ada.Strings;
         Value : constant String := Util.Properties.To_String (Item);
      begin
         if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
            Log.Debug ("Adding config {0} = {1}", Name, Value);

            Into.Set_Value (Name, Item);
         else
            declare
               New_Value : constant Object := Expand (Value, Local_Context);
            begin
               Log.Debug ("Adding config {0} = {1}",
                          Name, Util.Beans.Objects.To_String (New_Value));
               if Util.Beans.Objects.Is_Null (New_Value) then
                  Into.Set (Name, "");
               else
                  Into.Set_Value (Name, New_Value);
               end if;
            end;
         end if;
      end Process;

   begin
      Resolver.Set_Properties (Source);
      Local_Context.Set_Function_Mapper (Context.Get_Function_Mapper);
      Local_Context.Set_Resolver (Resolver'Unchecked_Access);

      Source.Iterate (Process'Access);
   end Expand;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return the
   --  string that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return String is
      Expr   : EL.Expressions.Expression;
      Result : Util.Beans.Objects.Object;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      Result := Expr.Get_Value (Context);
      return Util.Beans.Objects.To_String (Result);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
      Expr   : EL.Expressions.Expression;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      return Expr.Get_Value (Context);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Util.Beans.Objects.To_Object (Value);
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in Util.Beans.Objects.Object;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when Util.Beans.Objects.TYPE_STRING | Util.Beans.Objects.TYPE_WIDE_STRING =>
            declare
               S    : constant String := Util.Beans.Objects.To_String (Value);
               Expr : EL.Expressions.Expression;
            begin
               Expr := EL.Expressions.Create_Expression (S, Context);
               return Expr.Get_Value (Context);
            end;

         when others =>
            return Value;
      end case;

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

end EL.Utils;

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

with Ada.Strings.Unbounded;

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

with EL.Objects;
with EL.Expressions;
with EL.Contexts.Default;
with EL.Contexts.Properties;
package body EL.Utils is

   use Ada.Strings.Unbounded;
   use Util.Beans.Objects;

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

   --  ------------------------------
   --  Expand the properties stored in Source by evaluating the EL expressions
   --  used in the property values.  The EL context passed in Context can be used
   --  to specify the EL functions or some pre-defined beans that could be used.
   --  The EL context will integrate the source properties as well as properties stored
   --  in Into (only the Source properties will be evaluated).
   --  ------------------------------
   procedure Expand (Source  : in Util.Properties.Manager'Class;
                     Into    : in out Util.Properties.Manager'Class;
                     Context : in EL.Contexts.ELContext'Class) is

      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object;

      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      procedure Process (Name : in String;
                         Item : in Util.Beans.Objects.Object);

      type Local_Resolver is new EL.Contexts.Properties.Property_Resolver with null record;

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

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object is
         pragma Unreferenced (Resolver);
      begin
         if Base /= null then
            return Base.Get_Value (To_String (Name));

         elsif Into.Exists (Name) then
            declare
               Value  : constant String := Into.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         elsif Source.Exists (Name) then
            declare
               Value  : constant String := Source.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end Get_Value;

      Recursion : Natural := 10;

      --  ------------------------------
      --  Expand (recursively) the EL expression defined in Value by using
      --  the context.  The recursion is provided by the above context resolver which
      --  invokes Expand if it detects that a value is a possible EL expression.
      --  ------------------------------
      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object is
         Expr   : EL.Expressions.Expression;
         Result : Util.Beans.Objects.Object;
      begin
         if Recursion = 0 then
            Log.Error ("Too many level of recursion when evaluating expression: {0}", Value);
            return Util.Beans.Objects.Null_Object;
         end if;

         Recursion := Recursion - 1;
         Expr := EL.Expressions.Create_Expression (Value, Context);
         Result := Expr.Get_Value (Context);
         Recursion := Recursion + 1;
         return Result;

         --  Ignore any exception and copy the value verbatim.
      exception
         when others =>
            Recursion := Recursion + 1;
            return Util.Beans.Objects.To_Object (Value);
      end Expand;

      Resolver       : aliased Local_Resolver;
      Local_Context  : aliased EL.Contexts.Default.Default_Context;

      --  ------------------------------
      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      --  ------------------------------
      procedure Process (Name : in String;
                         Item : in Util.Properties.Value) is
         Value : constant String := Util.Properties.To_String (Item);
      begin
         if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
            Log.Debug ("Adding config {0} = {1}", Name, Value);

            Into.Set_Value (Name, Item);
         else
            declare
               New_Value : constant Object := Expand (Value, Local_Context);
            begin
               Log.Debug ("Adding config {0} = {1}",
                          Name, Util.Beans.Objects.To_String (New_Value));
               if Util.Beans.Objects.Is_Null (New_Value) then
                  Into.Set (Name, "");
               else
                  Into.Set_Value (Name, New_Value);
               end if;
            end;
         end if;
      end Process;

   begin
      Resolver.Set_Properties (Source);
      Local_Context.Set_Function_Mapper (Context.Get_Function_Mapper);
      Local_Context.Set_Resolver (Resolver'Unchecked_Access);

      Source.Iterate (Process'Access);
   end Expand;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return the
   --  string that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return String is
      Expr   : EL.Expressions.Expression;
      Result : Util.Beans.Objects.Object;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      Result := Expr.Get_Value (Context);
      return Util.Beans.Objects.To_String (Result);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
      Expr   : EL.Expressions.Expression;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      return Expr.Get_Value (Context);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Util.Beans.Objects.To_Object (Value);
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in Util.Beans.Objects.Object;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when Util.Beans.Objects.TYPE_STRING | Util.Beans.Objects.TYPE_WIDE_STRING =>
            declare
               S    : constant String := Util.Beans.Objects.To_String (Value);
               Expr : EL.Expressions.Expression;
            begin
               Expr := EL.Expressions.Create_Expression (S, Context);
               return Expr.Get_Value (Context);
            end;

         when others =>
            return Value;
      end case;

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

end EL.Utils;

Remove unecessary use Ada.Strings clause


--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  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 System;

with Interfaces.C.Pointers;

with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Objects.Buffers;
with GL.Pixels.Extensions;
with GL.Types.Colors;

package GL.Objects.Textures is
   pragma Preelaborate;

   package LE renames Low_Level.Enums;
   package PE renames Pixels.Extensions;

   type Dimension_Count is (One, Two, Three);

   function Get_Dimensions (Kind : LE.Texture_Kind) return Dimension_Count;

   function Maximum_Anisotropy return Single
     with Post => Maximum_Anisotropy'Result >= 16.0;

   -----------------------------------------------------------------------------
   --                            Basic Types                                  --
   -----------------------------------------------------------------------------

   type Minifying_Function is (Nearest, Linear, Nearest_Mipmap_Nearest,
                               Linear_Mipmap_Nearest, Nearest_Mipmap_Linear,
                               Linear_Mipmap_Linear);

   --  Has to be defined here because of following subtype declaration.
   for Minifying_Function use (Nearest                => 16#2600#,
                               Linear                 => 16#2601#,
                               Nearest_Mipmap_Nearest => 16#2700#,
                               Linear_Mipmap_Nearest  => 16#2701#,
                               Nearest_Mipmap_Linear  => 16#2702#,
                               Linear_Mipmap_Linear   => 16#2703#);
   for Minifying_Function'Size use Int'Size;

   subtype Magnifying_Function is Minifying_Function range Nearest .. Linear;

   type Wrapping_Mode is (Repeat, Clamp_To_Border, Clamp_To_Edge,
                          Mirrored_Repeat);

   --  Actual range is implementation-defined
   --
   --  - OpenGL 2.x: At least 2
   --  - OpenGL 3.x: At least 48
   --  - OpenGL 4.x: At least 80
   subtype Texture_Unit is UInt;

   subtype Image_Unit is UInt;

   subtype Mipmap_Level is Size;

   -----------------------------------------------------------------------------
   --                          Texture Objects                                --
   -----------------------------------------------------------------------------

   type Texture_Base (Kind : LE.Texture_Kind)
     is abstract new GL_Object with private;

   use type LE.Texture_Kind;

   function Has_Levels (Object : Texture_Base) return Boolean is
     (Object.Kind not in LE.Texture_Buffer | LE.Texture_Rectangle |
        LE.Texture_2D_Multisample | LE.Texture_2D_Multisample_Array)
   with Inline;

   overriding
   procedure Initialize_Id (Object : in out Texture_Base);

   overriding
   procedure Delete_Id (Object : in out Texture_Base);

   overriding
   function Identifier (Object : Texture_Base) return Types.Debug.Identifier is
     (Types.Debug.Texture);

   procedure Invalidate_Image (Object : Texture_Base; Level : Mipmap_Level)
     with Pre  => (if not Object.Has_Levels then Level = 0);

   procedure Invalidate_Sub_Image (Object : Texture_Base; Level : Mipmap_Level;
                                   X, Y, Z : Int; Width, Height, Depth : Size)
   with Pre  => (if not Object.Has_Levels then Level = 0);

   procedure Bind_Texture_Unit (Object : Texture_Base; Unit : Texture_Unit);

   procedure Bind_Image_Texture (Object : Texture_Base; Unit : Image_Unit);

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

   type Texture is new Texture_Base with private;

   function Dimensions (Object : Texture) return Dimension_Count;

   function Allocated (Object : Texture) return Boolean;

   procedure Clear_Using_Data
     (Object : Texture; Level : Mipmap_Level;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => not Object.Compressed (Level);

   procedure Clear_Using_Zeros
     (Object : Texture; Level : Mipmap_Level)
   with Pre => not Object.Compressed (Level);

   procedure Generate_Mipmap (Object : Texture);

   -----------------------------------------------------------------------------
   --                            Texture Parameters                           --
   -----------------------------------------------------------------------------

   procedure Set_Minifying_Filter     (Object : Texture; Filter : Minifying_Function);
   procedure Set_Magnifying_Filter    (Object : Texture; Filter : Magnifying_Function);
   procedure Set_Minimum_LoD          (Object : Texture; Level : Double);
   procedure Set_Maximum_LoD          (Object : Texture; Level : Double);
   procedure Set_Lowest_Mipmap_Level  (Object : Texture; Level : Mipmap_Level);
   procedure Set_Highest_Mipmap_Level (Object : Texture; Level : Mipmap_Level);

   function Minifying_Filter     (Object : Texture) return Minifying_Function;
   function Magnifying_Filter    (Object : Texture) return Magnifying_Function;
   function Minimum_LoD          (Object : Texture) return Double;
   function Maximum_LoD          (Object : Texture) return Double;
   function Lowest_Mipmap_Level  (Object : Texture) return Mipmap_Level;
   function Highest_Mipmap_Level (Object : Texture) return Mipmap_Level;
   --  TODO LoD_Bias (Double)

   procedure Set_Max_Anisotropy (Object : Texture; Degree : Double)
     with Pre => Degree >= 1.0;
   --  Set the maximum amount of anisotropy filtering to reduce the blurring
   --  of textures (caused by mipmap filtering) that are viewed at an
   --  oblique angle.
   --
   --  For best results, combine the use of anisotropy filtering with
   --  a Linear_Mipmap_Linear minification filter and a Linear maxification
   --  filter.

   function Max_Anisotropy (Object : Texture) return Double
     with Post => Max_Anisotropy'Result >= 1.0;

   procedure Set_X_Wrapping (Object : Texture; Mode : Wrapping_Mode);
   procedure Set_Y_Wrapping (Object : Texture; Mode : Wrapping_Mode);
   procedure Set_Z_Wrapping (Object : Texture; Mode : Wrapping_Mode);

   function X_Wrapping (Object : Texture) return Wrapping_Mode;
   function Y_Wrapping (Object : Texture) return Wrapping_Mode;
   function Z_Wrapping (Object : Texture) return Wrapping_Mode;

   procedure Set_Border_Color         (Object : Texture; Color : Colors.Color);
   function Border_Color              (Object : Texture) return Colors.Color;

   procedure Toggle_Compare_X_To_Texture (Object : Texture; Enabled : Boolean);
   procedure Set_Compare_Function        (Object : Texture; Func : Compare_Function);

   function Compare_X_To_Texture_Enabled (Object : Texture) return Boolean;
   function Current_Compare_Function     (Object : Texture) return Compare_Function;

   -----------------------------------------------------------------------------
   --                         Texture Level Parameters                        --
   -----------------------------------------------------------------------------

   function Width  (Object : Texture; Level : Mipmap_Level) return Size;
   function Height (Object : Texture; Level : Mipmap_Level) return Size;
   function Depth  (Object : Texture; Level : Mipmap_Level) return Size;

   function Internal_Format (Object : Texture; Level : Mipmap_Level)
     return Pixels.Internal_Format
   with Pre => Object.Allocated and not Object.Compressed (Level);

   function Compressed_Format (Object : Texture; Level : Mipmap_Level)
     return Pixels.Compressed_Format
   with Pre => Object.Allocated and Object.Compressed (Level);

   function Red_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Green_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Blue_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Alpha_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Depth_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;

   function Red_Size   (Object : Texture; Level : Mipmap_Level) return Size;
   function Green_Size (Object : Texture; Level : Mipmap_Level) return Size;
   function Blue_Size  (Object : Texture; Level : Mipmap_Level) return Size;
   function Alpha_Size (Object : Texture; Level : Mipmap_Level) return Size;
   function Depth_Size (Object : Texture; Level : Mipmap_Level) return Size;
   --  TODO Stencil_Size, Shared_Size

   function Compressed (Object : Texture; Level : Mipmap_Level) return Boolean;
   function Compressed_Image_Size (Object : Texture; Level : Mipmap_Level) return Size;
   --  TODO Pre => Object is compressed

   --  TODO Samples (Size), Fixed_Sample_Locations (Boolean) (if Object is multisampled)

   function Buffer_Offset (Object : Texture; Level : Mipmap_Level) return Size;
   function Buffer_Size   (Object : Texture; Level : Mipmap_Level) return Size;

   -----------------------------------------------------------------------------
   --                            Texture Units                                --
   -----------------------------------------------------------------------------

   function Active_Unit return Texture_Unit;

   function Texture_Unit_Count return Natural;

   -----------------------------------------------------------------------------
   --                        Buffer Texture Loading                           --
   -----------------------------------------------------------------------------

   type Buffer_Texture is new Texture_Base (Kind => LE.Texture_Buffer) with private;

   procedure Attach_Buffer (Object : Buffer_Texture;
                            Internal_Format : Pixels.Internal_Format_Buffer_Texture;
                            Buffer : Objects.Buffers.Buffer);

   procedure Attach_Buffer (Object : Buffer_Texture;
                            Internal_Format : Pixels.Internal_Format_Buffer_Texture;
                            Buffer : Objects.Buffers.Buffer;
                            Offset, Size : Types.Size);

   -----------------------------------------------------------------------------
   --                           Texture Loading                               --
   -----------------------------------------------------------------------------

   procedure Allocate_Storage
     (Object : in out Texture;
      Levels, Samples : Types.Size;
      Format : Pixels.Internal_Format;
      Width, Height, Depth : Types.Size;
      Fixed_Locations : Boolean := True)
   with Pre  => not Object.Allocated,
        Post => Object.Allocated;

   procedure Allocate_Storage
     (Object : in out Texture;
      Levels, Samples : Types.Size;
      Format : Pixels.Compressed_Format;
      Width, Height, Depth : Types.Size;
      Fixed_Locations : Boolean := True)
   with Pre  => not Object.Allocated and Object.Kind /= LE.Texture_Rectangle,
        Post => Object.Allocated;

   procedure Load_From_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => Object.Allocated and not Object.Compressed (Level);

   procedure Load_From_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Compressed_Format;
      Image_Size    : Types.Size;
      Source        : System.Address)
   with Pre => Object.Dimensions /= One and Object.Allocated and Object.Compressed (Level);

   procedure Copy_Data
     (Object  : Texture;
      Subject : Texture;
      Source_Level, Target_Level : Mipmap_Level)
   with Pre => Object.Allocated and Subject.Allocated;

   procedure Copy_Sub_Data
     (Object  : Texture;
      Subject : Texture;
      Source_Level, Target_Level : Mipmap_Level;
      Source_X, Source_Y, Source_Z : Types.Size := 0;
      Target_X, Target_Y, Target_Z : Types.Size := 0;
      Width, Height, Depth : Types.Size)
   with Pre => Object.Allocated and Subject.Allocated;

   procedure Clear_Using_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => not Object.Compressed (Level);

   procedure Clear_Using_Zeros
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size)
   with Pre => not Object.Compressed (Level);

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

   function Get_Compressed_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Format : Pixels.Compressed_Format) return not null Types.UByte_Array_Access
   with Pre => Object.Dimensions /= One and Object.Allocated and Object.Compressed (Level)
     and Object.Kind not in LE.Texture_2D_Multisample | LE.Texture_2D_Multisample_Array;

   generic
      with package Pointers is new Interfaces.C.Pointers (<>);
   package Texture_Pointers is

      type Element_Array_Access is access Pointers.Element_Array;

      procedure Free is new Ada.Unchecked_Deallocation
        (Object => Pointers.Element_Array, Name => Element_Array_Access);

      function Get_Data
        (Object : Texture;
         Level  : Mipmap_Level;
         X, Y, Z              : Types.Size := 0;
         Width, Height, Depth : Types.Positive_Size;
         Format    : Pixels.Format;
         Data_Type : PE.Non_Packed_Data_Type) return not null Element_Array_Access
      with Pre => Object.Allocated and
                    not Object.Compressed (Level) and PE.Compatible (Format, Data_Type);

   end Texture_Pointers;

private

   for Wrapping_Mode use (Repeat          => 16#2901#,
                          Clamp_To_Border => 16#812D#,
                          Clamp_To_Edge   => 16#812F#,
                          Mirrored_Repeat => 16#8370#);
   for Wrapping_Mode'Size use Int'Size;

   type Texture_Base (Kind : LE.Texture_Kind)
     is new GL_Object with null record;

   type Texture is new Texture_Base with record
      Allocated  : Boolean := False;
      Dimensions : Dimension_Count := Get_Dimensions (Texture.Kind);
   end record;

   type Buffer_Texture is new Texture_Base (Kind => LE.Texture_Buffer) with null record;

end GL.Objects.Textures;

--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  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 System;

with Interfaces.C.Pointers;

with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Objects.Buffers;
with GL.Pixels.Extensions;
with GL.Types.Colors;

package GL.Objects.Textures is
   pragma Preelaborate;

   package LE renames Low_Level.Enums;
   package PE renames Pixels.Extensions;

   type Dimension_Count is (One, Two, Three);

   function Get_Dimensions (Kind : LE.Texture_Kind) return Dimension_Count;

   function Maximum_Anisotropy return Single
     with Post => Maximum_Anisotropy'Result >= 16.0;

   -----------------------------------------------------------------------------
   --                            Basic Types                                  --
   -----------------------------------------------------------------------------

   type Minifying_Function is (Nearest, Linear, Nearest_Mipmap_Nearest,
                               Linear_Mipmap_Nearest, Nearest_Mipmap_Linear,
                               Linear_Mipmap_Linear);

   --  Has to be defined here because of following subtype declaration.
   for Minifying_Function use (Nearest                => 16#2600#,
                               Linear                 => 16#2601#,
                               Nearest_Mipmap_Nearest => 16#2700#,
                               Linear_Mipmap_Nearest  => 16#2701#,
                               Nearest_Mipmap_Linear  => 16#2702#,
                               Linear_Mipmap_Linear   => 16#2703#);
   for Minifying_Function'Size use Int'Size;

   subtype Magnifying_Function is Minifying_Function range Nearest .. Linear;

   type Wrapping_Mode is (Repeat, Clamp_To_Border, Clamp_To_Edge,
                          Mirrored_Repeat, Mirror_Clamp_To_Edge);

   --  Actual range is implementation-defined
   --
   --  - OpenGL 2.x: At least 2
   --  - OpenGL 3.x: At least 48
   --  - OpenGL 4.x: At least 80
   subtype Texture_Unit is UInt;

   subtype Image_Unit is UInt;

   subtype Mipmap_Level is Size;

   -----------------------------------------------------------------------------
   --                          Texture Objects                                --
   -----------------------------------------------------------------------------

   type Texture_Base (Kind : LE.Texture_Kind)
     is abstract new GL_Object with private;

   use type LE.Texture_Kind;

   function Has_Levels (Object : Texture_Base) return Boolean is
     (Object.Kind not in LE.Texture_Buffer | LE.Texture_Rectangle |
        LE.Texture_2D_Multisample | LE.Texture_2D_Multisample_Array)
   with Inline;

   overriding
   procedure Initialize_Id (Object : in out Texture_Base);

   overriding
   procedure Delete_Id (Object : in out Texture_Base);

   overriding
   function Identifier (Object : Texture_Base) return Types.Debug.Identifier is
     (Types.Debug.Texture);

   procedure Invalidate_Image (Object : Texture_Base; Level : Mipmap_Level)
     with Pre  => (if not Object.Has_Levels then Level = 0);

   procedure Invalidate_Sub_Image (Object : Texture_Base; Level : Mipmap_Level;
                                   X, Y, Z : Int; Width, Height, Depth : Size)
   with Pre  => (if not Object.Has_Levels then Level = 0);

   procedure Bind_Texture_Unit (Object : Texture_Base; Unit : Texture_Unit);

   procedure Bind_Image_Texture (Object : Texture_Base; Unit : Image_Unit);

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

   type Texture is new Texture_Base with private;

   function Dimensions (Object : Texture) return Dimension_Count;

   function Allocated (Object : Texture) return Boolean;

   procedure Clear_Using_Data
     (Object : Texture; Level : Mipmap_Level;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => not Object.Compressed (Level);

   procedure Clear_Using_Zeros
     (Object : Texture; Level : Mipmap_Level)
   with Pre => not Object.Compressed (Level);

   procedure Generate_Mipmap (Object : Texture);

   -----------------------------------------------------------------------------
   --                            Texture Parameters                           --
   -----------------------------------------------------------------------------

   procedure Set_Minifying_Filter     (Object : Texture; Filter : Minifying_Function);
   procedure Set_Magnifying_Filter    (Object : Texture; Filter : Magnifying_Function);
   procedure Set_Minimum_LoD          (Object : Texture; Level : Double);
   procedure Set_Maximum_LoD          (Object : Texture; Level : Double);
   procedure Set_Lowest_Mipmap_Level  (Object : Texture; Level : Mipmap_Level);
   procedure Set_Highest_Mipmap_Level (Object : Texture; Level : Mipmap_Level);

   function Minifying_Filter     (Object : Texture) return Minifying_Function;
   function Magnifying_Filter    (Object : Texture) return Magnifying_Function;
   function Minimum_LoD          (Object : Texture) return Double;
   function Maximum_LoD          (Object : Texture) return Double;
   function Lowest_Mipmap_Level  (Object : Texture) return Mipmap_Level;
   function Highest_Mipmap_Level (Object : Texture) return Mipmap_Level;
   --  TODO LoD_Bias (Double)

   procedure Set_Max_Anisotropy (Object : Texture; Degree : Double)
     with Pre => Degree >= 1.0;
   --  Set the maximum amount of anisotropy filtering to reduce the blurring
   --  of textures (caused by mipmap filtering) that are viewed at an
   --  oblique angle.
   --
   --  For best results, combine the use of anisotropy filtering with
   --  a Linear_Mipmap_Linear minification filter and a Linear maxification
   --  filter.

   function Max_Anisotropy (Object : Texture) return Double
     with Post => Max_Anisotropy'Result >= 1.0;

   procedure Set_X_Wrapping (Object : Texture; Mode : Wrapping_Mode);
   procedure Set_Y_Wrapping (Object : Texture; Mode : Wrapping_Mode);
   procedure Set_Z_Wrapping (Object : Texture; Mode : Wrapping_Mode);

   function X_Wrapping (Object : Texture) return Wrapping_Mode;
   function Y_Wrapping (Object : Texture) return Wrapping_Mode;
   function Z_Wrapping (Object : Texture) return Wrapping_Mode;

   procedure Set_Border_Color         (Object : Texture; Color : Colors.Color);
   function Border_Color              (Object : Texture) return Colors.Color;

   procedure Toggle_Compare_X_To_Texture (Object : Texture; Enabled : Boolean);
   procedure Set_Compare_Function        (Object : Texture; Func : Compare_Function);

   function Compare_X_To_Texture_Enabled (Object : Texture) return Boolean;
   function Current_Compare_Function     (Object : Texture) return Compare_Function;

   -----------------------------------------------------------------------------
   --                         Texture Level Parameters                        --
   -----------------------------------------------------------------------------

   function Width  (Object : Texture; Level : Mipmap_Level) return Size;
   function Height (Object : Texture; Level : Mipmap_Level) return Size;
   function Depth  (Object : Texture; Level : Mipmap_Level) return Size;

   function Internal_Format (Object : Texture; Level : Mipmap_Level)
     return Pixels.Internal_Format
   with Pre => Object.Allocated and not Object.Compressed (Level);

   function Compressed_Format (Object : Texture; Level : Mipmap_Level)
     return Pixels.Compressed_Format
   with Pre => Object.Allocated and Object.Compressed (Level);

   function Red_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Green_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Blue_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Alpha_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;
   function Depth_Type (Object : Texture; Level : Mipmap_Level)
     return Pixels.Channel_Data_Type;

   function Red_Size   (Object : Texture; Level : Mipmap_Level) return Size;
   function Green_Size (Object : Texture; Level : Mipmap_Level) return Size;
   function Blue_Size  (Object : Texture; Level : Mipmap_Level) return Size;
   function Alpha_Size (Object : Texture; Level : Mipmap_Level) return Size;
   function Depth_Size (Object : Texture; Level : Mipmap_Level) return Size;
   --  TODO Stencil_Size, Shared_Size

   function Compressed (Object : Texture; Level : Mipmap_Level) return Boolean;
   function Compressed_Image_Size (Object : Texture; Level : Mipmap_Level) return Size;
   --  TODO Pre => Object is compressed

   --  TODO Samples (Size), Fixed_Sample_Locations (Boolean) (if Object is multisampled)

   function Buffer_Offset (Object : Texture; Level : Mipmap_Level) return Size;
   function Buffer_Size   (Object : Texture; Level : Mipmap_Level) return Size;

   -----------------------------------------------------------------------------
   --                            Texture Units                                --
   -----------------------------------------------------------------------------

   function Active_Unit return Texture_Unit;

   function Texture_Unit_Count return Natural;

   -----------------------------------------------------------------------------
   --                        Buffer Texture Loading                           --
   -----------------------------------------------------------------------------

   type Buffer_Texture is new Texture_Base (Kind => LE.Texture_Buffer) with private;

   procedure Attach_Buffer (Object : Buffer_Texture;
                            Internal_Format : Pixels.Internal_Format_Buffer_Texture;
                            Buffer : Objects.Buffers.Buffer);

   procedure Attach_Buffer (Object : Buffer_Texture;
                            Internal_Format : Pixels.Internal_Format_Buffer_Texture;
                            Buffer : Objects.Buffers.Buffer;
                            Offset, Size : Types.Size);

   -----------------------------------------------------------------------------
   --                           Texture Loading                               --
   -----------------------------------------------------------------------------

   procedure Allocate_Storage
     (Object : in out Texture;
      Levels, Samples : Types.Size;
      Format : Pixels.Internal_Format;
      Width, Height, Depth : Types.Size;
      Fixed_Locations : Boolean := True)
   with Pre  => not Object.Allocated,
        Post => Object.Allocated;

   procedure Allocate_Storage
     (Object : in out Texture;
      Levels, Samples : Types.Size;
      Format : Pixels.Compressed_Format;
      Width, Height, Depth : Types.Size;
      Fixed_Locations : Boolean := True)
   with Pre  => not Object.Allocated and Object.Kind /= LE.Texture_Rectangle,
        Post => Object.Allocated;

   procedure Load_From_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => Object.Allocated and not Object.Compressed (Level);

   procedure Load_From_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Compressed_Format;
      Image_Size    : Types.Size;
      Source        : System.Address)
   with Pre => Object.Dimensions /= One and Object.Allocated and Object.Compressed (Level);

   procedure Copy_Data
     (Object  : Texture;
      Subject : Texture;
      Source_Level, Target_Level : Mipmap_Level)
   with Pre => Object.Allocated and Subject.Allocated;

   procedure Copy_Sub_Data
     (Object  : Texture;
      Subject : Texture;
      Source_Level, Target_Level : Mipmap_Level;
      Source_X, Source_Y, Source_Z : Types.Size := 0;
      Target_X, Target_Y, Target_Z : Types.Size := 0;
      Width, Height, Depth : Types.Size)
   with Pre => Object.Allocated and Subject.Allocated;

   procedure Clear_Using_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Source_Format : Pixels.Format;
      Source_Type   : Pixels.Data_Type;
      Source        : System.Address)
   with Pre => not Object.Compressed (Level);

   procedure Clear_Using_Zeros
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size)
   with Pre => not Object.Compressed (Level);

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

   function Get_Compressed_Data
     (Object : Texture;
      Level  : Mipmap_Level;
      X, Y, Z              : Types.Size := 0;
      Width, Height, Depth : Types.Positive_Size;
      Format : Pixels.Compressed_Format) return not null Types.UByte_Array_Access
   with Pre => Object.Dimensions /= One and Object.Allocated and Object.Compressed (Level)
     and Object.Kind not in LE.Texture_2D_Multisample | LE.Texture_2D_Multisample_Array;

   generic
      with package Pointers is new Interfaces.C.Pointers (<>);
   package Texture_Pointers is

      type Element_Array_Access is access Pointers.Element_Array;

      procedure Free is new Ada.Unchecked_Deallocation
        (Object => Pointers.Element_Array, Name => Element_Array_Access);

      function Get_Data
        (Object : Texture;
         Level  : Mipmap_Level;
         X, Y, Z              : Types.Size := 0;
         Width, Height, Depth : Types.Positive_Size;
         Format    : Pixels.Format;
         Data_Type : PE.Non_Packed_Data_Type) return not null Element_Array_Access
      with Pre => Object.Allocated and
                    not Object.Compressed (Level) and PE.Compatible (Format, Data_Type);

   end Texture_Pointers;

private

   for Wrapping_Mode use
     (Repeat               => 16#2901#,
      Clamp_To_Border      => 16#812D#,
      Clamp_To_Edge        => 16#812F#,
      Mirrored_Repeat      => 16#8370#,
      Mirror_Clamp_To_Edge => 16#8743#);
   for Wrapping_Mode'Size use Int'Size;

   type Texture_Base (Kind : LE.Texture_Kind)
     is new GL_Object with null record;

   type Texture is new Texture_Base with record
      Allocated  : Boolean := False;
      Dimensions : Dimension_Count := Get_Dimensions (Texture.Kind);
   end record;

   type Buffer_Texture is new Texture_Base (Kind => LE.Texture_Buffer) with null record;

end GL.Objects.Textures;

gl: Add Mirror_Clamp_To_Edge texture wrapping mode

 * Extension ARB_texture_mirror_clamp_to_edge (OpenGL 4.4)

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


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

with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Servlets.Ajax;
with ASF.Filters.Dump;
with ASF.Filters.Cache_Control;
with ASF.Servlets.Measures;

with ASF.Security.Servlets;
with ASF.Converters.Sizes;
with ASF.Applications;

with AWA.Users.Servlets;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Applications;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Wikis.Modules;
with AWA.Wikis.Previews;
with AWA.Jobs.Modules;
with AWA.Counters.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Comments.Modules;
with AWA.Services.Filters;
with AWA.Converters.Dates;

with Atlas.Microblog.Modules;
with Atlas.Reviews.Modules;
package Atlas.Applications is

   CONFIG_PATH  : constant String := "/atlas";
   CONTEXT_PATH : constant String := "/atlas";

   ATLAS_NS_URI : aliased constant String := "http://code.google.com/p/ada-awa/atlas";

   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   function Get_Gravatar_Link (Email : in String) return String;

   --  EL function to convert an Email address to a Gravatar image.
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object;

   type Application is new AWA.Applications.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application.
   procedure Initialize (App    : in Application_Access;
                         Config : in ASF.Applications.Config);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   overriding
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   overriding
   procedure Initialize_Filters (App : in out Application);

   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   overriding
   procedure Initialize_Modules (App : in out Application);

private

   type Application is new AWA.Applications.Application with record
      Self              : Application_Access;
      --  Application servlets and filters (add new servlet and filter instances here).
      Faces             : aliased ASF.Servlets.Faces.Faces_Servlet;
      Ajax              : aliased ASF.Servlets.Ajax.Ajax_Servlet;
      Files             : aliased ASF.Servlets.Files.File_Servlet;
      Dump              : aliased ASF.Filters.Dump.Dump_Filter;
      Service_Filter    : aliased AWA.Services.Filters.Service_Filter;
      Measures          : aliased ASF.Servlets.Measures.Measure_Servlet;
      No_Cache          : aliased ASF.Filters.Cache_Control.Cache_Control_Filter;

      --  Authentication servlet and filter.
      Auth              : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth       : aliased AWA.Users.Servlets.Verify_Auth_Servlet;

      --  Converters shared by web requests.
      Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;
      Size_Converter     : aliased ASF.Converters.Sizes.Size_Converter;

      --  The application modules.
      User_Module       : aliased AWA.Users.Modules.User_Module;
      Workspace_Module  : aliased AWA.Workspaces.Modules.Workspace_Module;
      Blog_Module       : aliased AWA.Blogs.Modules.Blog_Module;
      Mail_Module       : aliased AWA.Mail.Modules.Mail_Module;
      Job_Module        : aliased AWA.Jobs.Modules.Job_Module;
      Storage_Module    : aliased AWA.Storages.Modules.Storage_Module;
      Image_Module      : aliased AWA.Images.Modules.Image_Module;
      Vote_Module       : aliased AWA.Votes.Modules.Vote_Module;
      Question_Module   : aliased AWA.Questions.Modules.Question_Module;
      Tag_Module        : aliased AWA.Tags.Modules.Tag_Module;
      Comment_Module    : aliased AWA.Comments.Modules.Comment_Module;
      Wiki_Module       : aliased AWA.Wikis.Modules.Wiki_Module;
      Preview_Module    : aliased AWA.Wikis.Previews.Preview_Module;
      Counter_Module    : aliased AWA.Counters.Modules.Counter_Module;

      Microblog_Module  : aliased Atlas.Microblog.Modules.Microblog_Module;
      Review_Module     : aliased Atlas.Reviews.Modules.Review_Module;
   end record;

end Atlas.Applications;

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

with ASF.Servlets.Faces;
with Servlet.Core.Files;
with ASF.Servlets.Ajax;
with ASF.Filters.Dump;
with ASF.Filters.Cache_Control;
with Servlet.Core.Measures;

with ASF.Security.Servlets;
with ASF.Converters.Sizes;
with ASF.Applications;

with AWA.Users.Servlets;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Applications;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Wikis.Modules;
with AWA.Wikis.Previews;
with AWA.Jobs.Modules;
with AWA.Counters.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Comments.Modules;
with AWA.Services.Filters;
with AWA.Converters.Dates;

with Atlas.Microblog.Modules;
with Atlas.Reviews.Modules;
package Atlas.Applications is

   CONFIG_PATH  : constant String := "/atlas";
   CONTEXT_PATH : constant String := "/atlas";

   ATLAS_NS_URI : aliased constant String := "http://code.google.com/p/ada-awa/atlas";

   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   function Get_Gravatar_Link (Email : in String) return String;

   --  EL function to convert an Email address to a Gravatar image.
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object;

   type Application is new AWA.Applications.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application.
   procedure Initialize (App    : in Application_Access;
                         Config : in ASF.Applications.Config);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   overriding
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   overriding
   procedure Initialize_Filters (App : in out Application);

   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   overriding
   procedure Initialize_Modules (App : in out Application);

private

   type Application is new AWA.Applications.Application with record
      Self              : Application_Access;
      --  Application servlets and filters (add new servlet and filter instances here).
      Faces             : aliased ASF.Servlets.Faces.Faces_Servlet;
      Ajax              : aliased ASF.Servlets.Ajax.Ajax_Servlet;
      Files             : aliased Servlet.Core.Files.File_Servlet;
      Dump              : aliased ASF.Filters.Dump.Dump_Filter;
      Service_Filter    : aliased AWA.Services.Filters.Service_Filter;
      Measures          : aliased Servlet.Core.Measures.Measure_Servlet;
      No_Cache          : aliased ASF.Filters.Cache_Control.Cache_Control_Filter;

      --  Authentication servlet and filter.
      Auth              : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth       : aliased AWA.Users.Servlets.Verify_Auth_Servlet;

      --  Converters shared by web requests.
      Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;
      Size_Converter     : aliased ASF.Converters.Sizes.Size_Converter;

      --  The application modules.
      User_Module       : aliased AWA.Users.Modules.User_Module;
      Workspace_Module  : aliased AWA.Workspaces.Modules.Workspace_Module;
      Blog_Module       : aliased AWA.Blogs.Modules.Blog_Module;
      Mail_Module       : aliased AWA.Mail.Modules.Mail_Module;
      Job_Module        : aliased AWA.Jobs.Modules.Job_Module;
      Storage_Module    : aliased AWA.Storages.Modules.Storage_Module;
      Image_Module      : aliased AWA.Images.Modules.Image_Module;
      Vote_Module       : aliased AWA.Votes.Modules.Vote_Module;
      Question_Module   : aliased AWA.Questions.Modules.Question_Module;
      Tag_Module        : aliased AWA.Tags.Modules.Tag_Module;
      Comment_Module    : aliased AWA.Comments.Modules.Comment_Module;
      Wiki_Module       : aliased AWA.Wikis.Modules.Wiki_Module;
      Preview_Module    : aliased AWA.Wikis.Previews.Preview_Module;
      Counter_Module    : aliased AWA.Counters.Modules.Counter_Module;

      Microblog_Module  : aliased Atlas.Microblog.Modules.Microblog_Module;
      Review_Module     : aliased Atlas.Reviews.Modules.Review_Module;
   end record;

end Atlas.Applications;

Update to use the Servlet.Core package after migration of servlet in a separate project


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

with Util.Tests;

package Util.Strings.Tests is

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

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

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);
   procedure Test_Starts_With (T : in out Test);
   procedure Test_Ends_With (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

end Util.Strings.Tests;

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

with Util.Tests;

package Util.Strings.Tests is

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

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

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);
   procedure Test_Escape_Java (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);
   procedure Test_Starts_With (T : in out Test);
   procedure Test_Ends_With (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

end Util.Strings.Tests;

Declare Test_Escape_Java procedure

Declare Test_Escape_Java procedure


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := NONE + 1;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            if Next_Index = Permission_Index'Last then
               Log.Error ("Too many permission instantiated. "
                          & "Increase Security.Permissions.MAX_PERMISSION");
            else
               Next_Index := Next_Index + 1;
            end if;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   --  ------------------------------
   --  Check if the permission index set contains the given permission index.
   --  ------------------------------
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean is
      use Interfaces;
   begin
      return (Set (Natural (Index / 8)) and Shift_Left (1, Natural (Index mod 8))) /= 0;
   end Has_Permission;

   --  ------------------------------
   --  Add the permission index to the set.
   --  ------------------------------
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index) is
      use Interfaces;
      Pos : constant Natural := Natural (Index / 8);
   begin
      Set (Pos) := Set (Pos) or Shift_Left (1, Natural (Index mod 8));
   end Add_Permission;

   package body Definition is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Definition;

end Security.Permissions;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      --  Get the permission name associated with the index.
      function Get_Name (Index : in Permission_Index) return String;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := NONE + 1;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  ------------------------------
      --  Get the last permission index registered in the global permission map.
      --  ------------------------------
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index - 1;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            if Next_Index = Permission_Index'Last then
               Log.Error ("Too many permission instantiated. "
                          & "Increase Security.Permissions.MAX_PERMISSION");
            else
               Next_Index := Next_Index + 1;
            end if;
         end if;
      end Add_Permission;

      --  ------------------------------
      --  Get the permission name associated with the index.
      --  ------------------------------
      function Get_Name (Index : in Permission_Index) return String is
         Iter : Permission_Maps.Cursor := Map.First;
      begin
         while Permission_Maps.Has_Element (Iter) loop
            if Permission_Maps.Element (Iter) = Index then
               return Permission_Maps.Key (Iter);
            end if;
            Permission_Maps.Next (Iter);
         end loop;
         return "";
      end Get_Name;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the permission name given the index.
   --  ------------------------------
   function Get_Name (Index : in Permission_Index) return String is
   begin
      return Permission_Indexes.Get_Name (Index);
   end Get_Name;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   --  ------------------------------
   --  Check if the permission index set contains the given permission index.
   --  ------------------------------
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean is
      use Interfaces;
   begin
      return (Set (Natural (Index / 8)) and Shift_Left (1, Natural (Index mod 8))) /= 0;
   end Has_Permission;

   --  ------------------------------
   --  Add the permission index to the set.
   --  ------------------------------
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index) is
      use Interfaces;
      Pos : constant Natural := Natural (Index / 8);
   begin
      Set (Pos) := Set (Pos) or Shift_Left (1, Natural (Index mod 8));
   end Add_Permission;

   package body Definition is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Definition;

end Security.Permissions;

Declare and implement the Get_Name protected operation Implement the Get_Name public function


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

with Util.Log.Loggers;
package body Util.Beans.Factory is

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

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Factory    : in out Bean_Factory;
                       Name       : in String;
                       Definition : in Bean_Definition_Access;
                       Scope      : in Scope_Type := REQUEST_SCOPE) is
      B : constant Simple_Binding_Access := new Simple_Binding '(Def   => Definition,
                                                                 Scope => Scope);
   begin
      Log.Info ("Register bean '{0}' in scope {1}", Name, Scope_Type'Image (Scope));

      Register (Factory, Name, B.all'Access);
   end Register;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Bind    : in Binding_Access) is
   begin
      Log.Info ("Register bean binding '{0}'", Name);

      Factory.Map.Include (Key => To_Unbounded_String (Name),
                           New_Item => Bind);
   end Register;

   --  ------------------------------
   --  Register all the definitions from a factory to a main factory.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       From    : in Bean_Factory) is
      Pos : Bean_Maps.Cursor := Bean_Maps.First (From.Map);
   begin
      while Bean_Maps.Has_Element (Pos) loop
         Factory.Map.Include (Key      => Bean_Maps.Key (Pos),
                              New_Item => Bean_Maps.Element (Pos));
         Bean_Maps.Next (Pos);
      end loop;
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (Factory    : in Bean_Factory;
                     Name       : in Unbounded_String;
                     Result     : out Util.Beans.Basic.Readonly_Bean_Access;
                     Definition : out Bean_Definition_Access;
                     Scope      : out Scope_Type) is
      Pos : constant Bean_Maps.Cursor := Factory.Map.Find (Name);
   begin
      if Bean_Maps.Has_Element (Pos) then
         declare
            B : constant Binding_Access := Bean_Maps.Element (Pos);
         begin
            B.Create (Name, Result, Definition, Scope);
         end;
      end if;
   end Create;

   procedure Create (Factory    : in Simple_Binding;
                     Name       : in Ada.Strings.Unbounded.Unbounded_String;
                     Result     : out Util.Beans.Basic.Readonly_Bean_Access;
                     Definition : out Bean_Definition_Access;
                     Scope      : out Scope_Type) is
      pragma Unreferenced (Name);
   begin
      Result     := Factory.Def.Create;
      Definition := Factory.Def;
      Scope      := Factory.Scope;
   end Create;

end Util.Beans.Factory;

-----------------------------------------------------------------------
--  util-beans-factory -- Bean Registration and Factory
--  Copyright (C) 2009, 2010, 2015, 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.Log.Loggers;
package body Util.Beans.Factory is

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

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Factory    : in out Bean_Factory;
                       Name       : in String;
                       Definition : in Bean_Definition_Access;
                       Scope      : in Scope_Type := REQUEST_SCOPE) is
      B : constant Simple_Binding_Access := new Simple_Binding '(Def   => Definition,
                                                                 Scope => Scope);
   begin
      Log.Info ("Register bean '{0}' in scope {1}", Name, Scope_Type'Image (Scope));

      Register (Factory, Name, B.all'Access);
   end Register;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Bind    : in Binding_Access) is
   begin
      Log.Info ("Register bean binding '{0}'", Name);

      Factory.Map.Include (Key => To_Unbounded_String (Name),
                           New_Item => Bind);
   end Register;

   --  ------------------------------
   --  Register all the definitions from a factory to a main factory.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       From    : in Bean_Factory) is
      Pos : Bean_Maps.Cursor := Bean_Maps.First (From.Map);
   begin
      while Bean_Maps.Has_Element (Pos) loop
         Factory.Map.Include (Key      => Bean_Maps.Key (Pos),
                              New_Item => Bean_Maps.Element (Pos));
         Bean_Maps.Next (Pos);
      end loop;
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (Factory    : in Bean_Factory;
                     Name       : in Unbounded_String;
                     Result     : out Util.Beans.Basic.Readonly_Bean_Access;
                     Definition : out Bean_Definition_Access;
                     Scope      : out Scope_Type) is
      Pos : constant Bean_Maps.Cursor := Factory.Map.Find (Name);
   begin
      if Bean_Maps.Has_Element (Pos) then
         declare
            B : constant Binding_Access := Bean_Maps.Element (Pos);
         begin
            B.Create (Name, Result, Definition, Scope);
         end;
      end if;
   end Create;

   procedure Create (Factory    : in Simple_Binding;
                     Name       : in Ada.Strings.Unbounded.Unbounded_String;
                     Result     : out Util.Beans.Basic.Readonly_Bean_Access;
                     Definition : out Bean_Definition_Access;
                     Scope      : out Scope_Type) is
      pragma Unreferenced (Name);
   begin
      Result     := Factory.Def.Create;
      Definition := Factory.Def;
      Scope      := Factory.Scope;
   end Create;

end Util.Beans.Factory;

Fix header style

Fix header style