-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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 ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Services.Contexts;
with AWA.Applications;
package body AWA.Modules is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Boolean := False) return Boolean is
      Value : constant String := Plugin.Config.Get (Name, Boolean'Image (Default));
   begin
      if Value in "yes" | "true" | "1" then
         return True;
      else
         return False;
      end if;

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

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

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  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 (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                            return ADO.Sessions.Session is
      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Session (Ctx);
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Master_Session (Ctx);
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016, 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 ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Services.Contexts;
with AWA.Applications;
package body AWA.Modules is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Boolean := False) return Boolean is
      Value : constant String := Plugin.Config.Get (Name, Boolean'Image (Default));
   begin
      if Value in "yes" | "true" | "1" then
         return True;
      else
         return False;
      end if;

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

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

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  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 (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                         return ADO.Sessions.Session is
      pragma Unreferenced (Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Session (Ctx);
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
      pragma Unreferenced (Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Master_Session (Ctx);
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

Fix compilation warning

Fix compilation warning


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

   Not_Found : exception;

   type Frame_Type is private;

   subtype Frame_Table is MAT.Events.Frame_Table;

   --  Return the parent frame.
   function Parent (Frame : in Frame_Type) return Frame_Type;

   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table;

   --  Returns all the direct calls made by the current frame.
   function Calls (Frame : in Frame_Type) return Frame_Table;

   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural;

   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   function Current_Depth (Frame : in Frame_Type) return Natural;

   --  Create a root for stack frame representation.
   function Create_Root return Frame_Type;

   --  Destroy the frame tree recursively.
   procedure Destroy (Frame : in out Frame_Type);

   --  Release the frame when its reference is no longer necessary.
   procedure Release (Frame : in Frame_Type);

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

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type;

   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural);
private

   Frame_Group_Size : constant Natural := 4;

   subtype Local_Depth_Type is Natural range 0 .. Frame_Group_Size;

   subtype Mini_Frame_Table is Frame_Table (1 .. Local_Depth_Type'Last);

   type Frame;
   type Frame_Type is access all Frame;

   type Frame is record
      Parent   : Frame_Type := null;
      Next     : Frame_Type := null;
      Children : Frame_Type := null;
      Used     : Natural   := 0;
      Depth    : Natural   := 0;
      Calls    : Mini_Frame_Table;
      Local_Depth : Local_Depth_Type := 0;
   end record;

end MAT.Frames;

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

   Not_Found : exception;

   type Frame_Type is private;

   subtype Frame_Table is MAT.Events.Frame_Table;

   --  Return the parent frame.
   function Parent (Frame : in Frame_Type) return Frame_Type;

   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table;

   --  Returns all the direct calls made by the current frame.
   function Calls (Frame : in Frame_Type) return Frame_Table;

   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural;

   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   function Current_Depth (Frame : in Frame_Type) return Natural;

   --  Create a root for stack frame representation.
   function Create_Root return Frame_Type;

   --  Destroy the frame tree recursively.
   procedure Destroy (Frame : in out Frame_Type);

   --  Release the frame when its reference is no longer necessary.
   procedure Release (Frame : in Frame_Type);

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

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type;

   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural);

   --  Check whether the frame contains a call to the function described by the address range.
   function In_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean;

private

   Frame_Group_Size : constant Natural := 4;

   subtype Local_Depth_Type is Natural range 0 .. Frame_Group_Size;

   subtype Mini_Frame_Table is Frame_Table (1 .. Local_Depth_Type'Last);

   type Frame;
   type Frame_Type is access all Frame;

   type Frame is record
      Parent   : Frame_Type := null;
      Next     : Frame_Type := null;
      Children : Frame_Type := null;
      Used     : Natural   := 0;
      Depth    : Natural   := 0;
      Calls    : Mini_Frame_Table;
      Local_Depth : Local_Depth_Type := 0;
   end record;

end MAT.Frames;

Declare the In_Function function to check if the frame contains calls of a given function


--  Copyright (c) 2013 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 Ada.Containers.Indefinite_Holders;
with Ada.Unchecked_Conversion;

with GL.API;
with GL.Enums.Getter;
with GL.Pixels.Queries;

package body GL.Objects.Framebuffers is

   function Valid_Attachment
     (Attachment : Attachment_Point;
      Texture    : Textures.Texture) return Boolean
   is
      use all type GL.Pixels.Internal_Format;

      Format : GL.Pixels.Internal_Format renames Texture.Internal_Format (Level => 0);
   begin
      case Attachment is
         when Depth_Stencil_Attachment =>
            return Format in Depth24_Stencil8 | Depth32F_Stencil8;
         when Depth_Attachment =>
            return Format in Depth_Component16 | Depth_Component24 | Depth_Component32F;
         when Stencil_Attachment =>
            return Format in Stencil_Index8;
         when others =>
            return GL.Pixels.Queries.Color_Renderable (Format, Texture.Kind);
      end case;
   end Valid_Attachment;

   function Status
     (Object : Framebuffer;
      Target : Framebuffer_Target'Class) return Framebuffer_Status is
   begin
      return API.Check_Named_Framebuffer_Status (Object.Reference.GL_Id, Target.Kind);
   end Status;

   procedure Set_Draw_Buffer
     (Object   : Framebuffer;
      Selector : Buffers.Color_Buffer_Selector) is
   begin
      Object.Set_Draw_Buffers ((1 => Selector));
   end Set_Draw_Buffer;

   procedure Set_Draw_Buffers
     (Object : Framebuffer;
      List   : Buffers.Color_Buffer_List) is
   begin
      API.Named_Framebuffer_Draw_Buffers (Object.Reference.GL_Id, List'Length, List);
      Raise_Exception_On_OpenGL_Error;
   end Set_Draw_Buffers;

   procedure Set_Read_Buffer (Object : Framebuffer; Selector : Buffers.Color_Buffer_Selector) is
   begin
      API.Named_Framebuffer_Read_Buffer (Object.Reference.GL_Id, Selector);
      Raise_Exception_On_OpenGL_Error;
   end Set_Read_Buffer;

   procedure Attach_Texture (Object : Framebuffer;
                             Attachment : Attachment_Point;
                             Texture_Object : Textures.Texture;
                             Level : Textures.Mipmap_Level) is
   begin
      API.Named_Framebuffer_Texture (Object.Reference.GL_Id, Attachment,
                                     Texture_Object.Raw_Id, Level);
      Raise_Exception_On_OpenGL_Error;
   end Attach_Texture;

   procedure Attach_Texture_Layer (Object : Framebuffer;
                                   Attachment : Attachment_Point;
                                   Texture_Object : Textures.Texture;
                                   Level : Textures.Mipmap_Level;
                                   Layer : Natural) is
   begin
      API.Named_Framebuffer_Texture_Layer (Object.Reference.GL_Id, Attachment,
                                           Texture_Object.Raw_Id, Level, Int (Layer));
      Raise_Exception_On_OpenGL_Error;
   end Attach_Texture_Layer;

   procedure Detach (Object : Framebuffer; Attachment : Attachment_Point) is
   begin
      API.Named_Framebuffer_Texture (Object.Reference.GL_Id, Attachment, 0, 0);
      Raise_Exception_On_OpenGL_Error;
   end Detach;

   procedure Invalidate_Data (Object : Framebuffer;
                              Attachments : Attachment_List) is
   begin
      API.Invalidate_Named_Framebuffer_Data
        (Object.Reference.GL_Id, Attachments'Length, Attachments);
      Raise_Exception_On_OpenGL_Error;
   end Invalidate_Data;

   procedure Invalidate_Sub_Data (Object        : Framebuffer;
                                  Attachments   : Attachment_List;
                                  X, Y          : Int;
                                  Width, Height : Size) is
   begin
      API.Invalidate_Named_Framebuffer_Sub_Data (Object.Reference.GL_Id, Attachments'Length,
                                                 Attachments, X, Y, Width, Height);
      Raise_Exception_On_OpenGL_Error;
   end Invalidate_Sub_Data;

   procedure Blit (Read_Object, Draw_Object : Framebuffer;
                   Src_X0, Src_Y0, Src_X1, Src_Y1,
                   Dst_X0, Dst_Y0, Dst_X1, Dst_Y1 : Int;
                   Mask : Buffers.Buffer_Bits;
                   Filter : Textures.Magnifying_Function)
   is
      use type Low_Level.Bitfield;

      function Convert is new Ada.Unchecked_Conversion
        (Buffers.Buffer_Bits, Low_Level.Bitfield);

      Raw_Bits : constant Low_Level.Bitfield
        := Convert (Mask) and 2#0100010100000000#;
   begin
      API.Blit_Named_Framebuffer (Read_Object.Reference.GL_Id,
                                  Draw_Object.Reference.GL_Id,
                                  Src_X0, Src_Y0, Src_X1, Src_Y1,
                                  Dst_X0, Dst_Y0, Dst_X1, Dst_Y1,
                                  Raw_Bits, Filter);
      Raise_Exception_On_OpenGL_Error;
   end Blit;

   procedure Set_Default_Width (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Width, Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Width;

   function Default_Width (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Width, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Width;

   function Max_Framebuffer_Width return Size is
      Ret : Size := 16_384;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Width, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Width;

   procedure Set_Default_Height (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Height,
                                            Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Height;

   function Default_Height (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Height, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Height;

   function Max_Framebuffer_Height return Size is
      Ret : Size := 16_384;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Height, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Height;

   procedure Set_Default_Layers (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Layers, Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Layers;

   function Default_Layers (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Layers, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Layers;

   function Max_Framebuffer_Layers return Size is
      Ret : Size := 2_048;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Layers, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Layers;

   procedure Set_Default_Samples (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Samples,
                                            Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Samples;

   function Default_Samples (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Samples, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Samples;

   function Max_Framebuffer_Samples return Size is
      Ret : Size := 4;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Samples, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Samples;

   procedure Set_Default_Fixed_Sample_Locations (Object : Framebuffer; Value : Boolean) is
   begin
      API.Named_Framebuffer_Parameter_Bool (Object.Reference.GL_Id,
                                            Enums.Default_Fixed_Sample_Locations,
                                            Low_Level.Bool (Value));
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Fixed_Sample_Locations;

   function Default_Fixed_Sample_Locations (Object : Framebuffer) return Boolean is
      Ret : aliased Low_Level.Bool;
   begin
      API.Get_Named_Framebuffer_Parameter_Bool
        (Object.Reference.GL_Id, Enums.Default_Fixed_Sample_Locations,
         Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Boolean (Ret);
   end Default_Fixed_Sample_Locations;

   overriding
   procedure Initialize_Id (Object : in out Framebuffer) is
      New_Id : UInt := 0;
   begin
      API.Create_Framebuffers (1, New_Id);
      Raise_Exception_On_OpenGL_Error;
      Object.Reference.GL_Id := New_Id;
      Object.Reference.Initialized := True;
   end Initialize_Id;

   overriding
   procedure Delete_Id (Object : in out Framebuffer) is
      Arr : constant Low_Level.UInt_Array := (1 => Object.Reference.GL_Id);
   begin
      API.Delete_Framebuffers (1, Arr);
      Raise_Exception_On_OpenGL_Error;
      Object.Reference.GL_Id := 0;
      Object.Reference.Initialized := False;
   end Delete_Id;

   package Framebuffer_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Framebuffer'Class);

   type Framebuffer_Target_Array is
     array (Enums.Framebuffer_Kind) of Framebuffer_Holder.Holder;

   Current_Framebuffers : Framebuffer_Target_Array;

   procedure Bind (Target : Framebuffer_Target;
                   Object : Framebuffer'Class) is
      Holder : Framebuffer_Holder.Holder := Current_Framebuffers (Target.Kind);
   begin
      if Holder.Is_Empty or else Object /= Holder.Element then
         API.Bind_Framebuffer (Target.Kind, Object.Reference.GL_Id);
         Raise_Exception_On_OpenGL_Error;
         Holder.Replace_Element (Object);
      end if;
   end Bind;

   function Current (Target : Framebuffer_Target) return Framebuffer'Class is
      Holder : constant Framebuffer_Holder.Holder := Current_Framebuffers (Target.Kind);
   begin
      if Holder.Is_Empty then
         raise No_Object_Bound_Exception with Target.Kind'Image;
      else
         return Holder.Element;
      end if;
   end Current;

   procedure Clear_Color_Buffer (Object : Framebuffer;
                                 Index  : Buffers.Draw_Buffer_Index;
                                 Value  : Colors.Color) is
   begin
      API.Clear_Named_Framebuffer_Color_Real
        (Object.Reference.GL_Id, Enums.Color_Buffer, Index, Value);
      --  TODO Use *fv to clear fixed- and floating-point, *iv for signed int, *uiv for unsigned
      Raise_Exception_On_OpenGL_Error;
   end Clear_Color_Buffer;

   procedure Clear_Depth_Buffer (Object : Framebuffer; Value : Buffers.Depth) is
      Aliased_Value : aliased Buffers.Depth := Value;
   begin
      API.Clear_Named_Framebuffer_Depth
        (Object.Reference.GL_Id, Enums.Depth_Buffer, 0, Aliased_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Depth_Buffer;

   procedure Clear_Stencil_Buffer (Object : Framebuffer; Value : Buffers.Stencil_Index) is
      Aliased_Value : aliased Buffers.Stencil_Index := Value;
   begin
      API.Clear_Named_Framebuffer_Stencil
        (Object.Reference.GL_Id, Enums.Stencil_Buffer, 0, Aliased_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Stencil_Buffer;

   procedure Clear_Depth_And_Stencil_Buffer (Object : Framebuffer;
                                             Depth_Value   : Buffers.Depth;
                                             Stencil_Value : Buffers.Stencil_Index) is
   begin
      API.Clear_Named_Framebuffer_Depth_Stencil
        (Object.Reference.GL_Id, Enums.Depth_Stencil_Buffer, 0, Depth_Value, Stencil_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Depth_And_Stencil_Buffer;

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

   type Default_Framebuffer_Type is new Framebuffer with null record;

   overriding
   procedure Initialize_Id (Object : in out Default_Framebuffer_Type) is null;

   overriding
   procedure Delete_Id (Object : in out Default_Framebuffer_Type) is null;

   Default_FB : constant Default_Framebuffer_Type
     := Default_Framebuffer_Type'(GL_Object with null record);

   function Default_Framebuffer return Framebuffer is (Framebuffer (Default_FB));

end GL.Objects.Framebuffers;

--  Copyright (c) 2013 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 Ada.Containers.Indefinite_Holders;
with Ada.Unchecked_Conversion;

with GL.API;
with GL.Enums.Getter;
with GL.Pixels.Queries;

package body GL.Objects.Framebuffers is

   function Valid_Attachment
     (Attachment : Attachment_Point;
      Texture    : Textures.Texture) return Boolean
   is
      use all type GL.Pixels.Internal_Format;

      Format : GL.Pixels.Internal_Format renames Texture.Internal_Format (Level => 0);
   begin
      case Attachment is
         when Depth_Stencil_Attachment =>
            return Format in Depth24_Stencil8 | Depth32F_Stencil8;
         when Depth_Attachment =>
            return Format in Depth_Component16 | Depth_Component24 | Depth_Component32F;
         when Stencil_Attachment =>
            return Format in Stencil_Index8;
         when others =>
            return GL.Pixels.Queries.Color_Renderable (Format, Texture.Kind);
      end case;
   end Valid_Attachment;

   function Status
     (Object : Framebuffer;
      Target : Framebuffer_Target'Class) return Framebuffer_Status is
   begin
      return API.Check_Named_Framebuffer_Status (Object.Reference.GL_Id, Target.Kind);
   end Status;

   procedure Set_Draw_Buffer
     (Object   : Framebuffer;
      Selector : Buffers.Color_Buffer_Selector)
   is
      subtype Index_Type is Buffers.Draw_Buffer_Index;
   begin
      Object.Set_Draw_Buffers
        ((Index_Type'First => Selector,
          Index_Type'First + 1 .. Index_Type'Last => Buffers.None));
   end Set_Draw_Buffer;

   procedure Set_Draw_Buffers
     (Object : Framebuffer;
      List   : Buffers.Color_Buffer_List) is
   begin
      API.Named_Framebuffer_Draw_Buffers (Object.Reference.GL_Id, List'Length, List);
      Raise_Exception_On_OpenGL_Error;
   end Set_Draw_Buffers;

   procedure Set_Read_Buffer (Object : Framebuffer; Selector : Buffers.Color_Buffer_Selector) is
   begin
      API.Named_Framebuffer_Read_Buffer (Object.Reference.GL_Id, Selector);
      Raise_Exception_On_OpenGL_Error;
   end Set_Read_Buffer;

   procedure Attach_Texture (Object : Framebuffer;
                             Attachment : Attachment_Point;
                             Texture_Object : Textures.Texture;
                             Level : Textures.Mipmap_Level) is
   begin
      API.Named_Framebuffer_Texture (Object.Reference.GL_Id, Attachment,
                                     Texture_Object.Raw_Id, Level);
      Raise_Exception_On_OpenGL_Error;
   end Attach_Texture;

   procedure Attach_Texture_Layer (Object : Framebuffer;
                                   Attachment : Attachment_Point;
                                   Texture_Object : Textures.Texture;
                                   Level : Textures.Mipmap_Level;
                                   Layer : Natural) is
   begin
      API.Named_Framebuffer_Texture_Layer (Object.Reference.GL_Id, Attachment,
                                           Texture_Object.Raw_Id, Level, Int (Layer));
      Raise_Exception_On_OpenGL_Error;
   end Attach_Texture_Layer;

   procedure Detach (Object : Framebuffer; Attachment : Attachment_Point) is
   begin
      API.Named_Framebuffer_Texture (Object.Reference.GL_Id, Attachment, 0, 0);
      Raise_Exception_On_OpenGL_Error;
   end Detach;

   procedure Invalidate_Data (Object : Framebuffer;
                              Attachments : Attachment_List) is
   begin
      API.Invalidate_Named_Framebuffer_Data
        (Object.Reference.GL_Id, Attachments'Length, Attachments);
      Raise_Exception_On_OpenGL_Error;
   end Invalidate_Data;

   procedure Invalidate_Sub_Data (Object        : Framebuffer;
                                  Attachments   : Attachment_List;
                                  X, Y          : Int;
                                  Width, Height : Size) is
   begin
      API.Invalidate_Named_Framebuffer_Sub_Data (Object.Reference.GL_Id, Attachments'Length,
                                                 Attachments, X, Y, Width, Height);
      Raise_Exception_On_OpenGL_Error;
   end Invalidate_Sub_Data;

   procedure Blit (Read_Object, Draw_Object : Framebuffer;
                   Src_X0, Src_Y0, Src_X1, Src_Y1,
                   Dst_X0, Dst_Y0, Dst_X1, Dst_Y1 : Int;
                   Mask : Buffers.Buffer_Bits;
                   Filter : Textures.Magnifying_Function)
   is
      use type Low_Level.Bitfield;

      function Convert is new Ada.Unchecked_Conversion
        (Buffers.Buffer_Bits, Low_Level.Bitfield);

      Raw_Bits : constant Low_Level.Bitfield
        := Convert (Mask) and 2#0100010100000000#;
   begin
      API.Blit_Named_Framebuffer (Read_Object.Reference.GL_Id,
                                  Draw_Object.Reference.GL_Id,
                                  Src_X0, Src_Y0, Src_X1, Src_Y1,
                                  Dst_X0, Dst_Y0, Dst_X1, Dst_Y1,
                                  Raw_Bits, Filter);
      Raise_Exception_On_OpenGL_Error;
   end Blit;

   procedure Set_Default_Width (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Width, Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Width;

   function Default_Width (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Width, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Width;

   function Max_Framebuffer_Width return Size is
      Ret : Size := 16_384;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Width, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Width;

   procedure Set_Default_Height (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Height,
                                            Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Height;

   function Default_Height (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Height, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Height;

   function Max_Framebuffer_Height return Size is
      Ret : Size := 16_384;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Height, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Height;

   procedure Set_Default_Layers (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Layers, Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Layers;

   function Default_Layers (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Layers, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Layers;

   function Max_Framebuffer_Layers return Size is
      Ret : Size := 2_048;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Layers, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Layers;

   procedure Set_Default_Samples (Object : Framebuffer; Value : Size) is
   begin
      API.Named_Framebuffer_Parameter_Size (Object.Reference.GL_Id,
                                            Enums.Default_Samples,
                                            Value);
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Samples;

   function Default_Samples (Object : Framebuffer) return Size is
      Ret : aliased Size;
   begin
      API.Get_Named_Framebuffer_Parameter_Size
        (Object.Reference.GL_Id, Enums.Default_Samples, Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Default_Samples;

   function Max_Framebuffer_Samples return Size is
      Ret : Size := 4;
   begin
      API.Get_Size (Enums.Getter.Max_Framebuffer_Samples, Ret);
      Raise_Exception_On_OpenGL_Error;
      return Ret;
   end Max_Framebuffer_Samples;

   procedure Set_Default_Fixed_Sample_Locations (Object : Framebuffer; Value : Boolean) is
   begin
      API.Named_Framebuffer_Parameter_Bool (Object.Reference.GL_Id,
                                            Enums.Default_Fixed_Sample_Locations,
                                            Low_Level.Bool (Value));
      Raise_Exception_On_OpenGL_Error;
   end Set_Default_Fixed_Sample_Locations;

   function Default_Fixed_Sample_Locations (Object : Framebuffer) return Boolean is
      Ret : aliased Low_Level.Bool;
   begin
      API.Get_Named_Framebuffer_Parameter_Bool
        (Object.Reference.GL_Id, Enums.Default_Fixed_Sample_Locations,
         Ret'Unchecked_Access);
      Raise_Exception_On_OpenGL_Error;
      return Boolean (Ret);
   end Default_Fixed_Sample_Locations;

   overriding
   procedure Initialize_Id (Object : in out Framebuffer) is
      New_Id : UInt := 0;
   begin
      API.Create_Framebuffers (1, New_Id);
      Raise_Exception_On_OpenGL_Error;
      Object.Reference.GL_Id := New_Id;
      Object.Reference.Initialized := True;
   end Initialize_Id;

   overriding
   procedure Delete_Id (Object : in out Framebuffer) is
      Arr : constant Low_Level.UInt_Array := (1 => Object.Reference.GL_Id);
   begin
      API.Delete_Framebuffers (1, Arr);
      Raise_Exception_On_OpenGL_Error;
      Object.Reference.GL_Id := 0;
      Object.Reference.Initialized := False;
   end Delete_Id;

   package Framebuffer_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Framebuffer'Class);

   type Framebuffer_Target_Array is
     array (Enums.Framebuffer_Kind) of Framebuffer_Holder.Holder;

   Current_Framebuffers : Framebuffer_Target_Array;

   procedure Bind (Target : Framebuffer_Target;
                   Object : Framebuffer'Class) is
      Holder : Framebuffer_Holder.Holder := Current_Framebuffers (Target.Kind);
   begin
      if Holder.Is_Empty or else Object /= Holder.Element then
         API.Bind_Framebuffer (Target.Kind, Object.Reference.GL_Id);
         Raise_Exception_On_OpenGL_Error;
         Holder.Replace_Element (Object);
      end if;
   end Bind;

   function Current (Target : Framebuffer_Target) return Framebuffer'Class is
      Holder : constant Framebuffer_Holder.Holder := Current_Framebuffers (Target.Kind);
   begin
      if Holder.Is_Empty then
         raise No_Object_Bound_Exception with Target.Kind'Image;
      else
         return Holder.Element;
      end if;
   end Current;

   procedure Clear_Color_Buffer (Object : Framebuffer;
                                 Index  : Buffers.Draw_Buffer_Index;
                                 Value  : Colors.Color) is
   begin
      API.Clear_Named_Framebuffer_Color_Real
        (Object.Reference.GL_Id, Enums.Color_Buffer, Index, Value);
      --  TODO Use *fv to clear fixed- and floating-point, *iv for signed int, *uiv for unsigned
      Raise_Exception_On_OpenGL_Error;
   end Clear_Color_Buffer;

   procedure Clear_Depth_Buffer (Object : Framebuffer; Value : Buffers.Depth) is
      Aliased_Value : aliased Buffers.Depth := Value;
   begin
      API.Clear_Named_Framebuffer_Depth
        (Object.Reference.GL_Id, Enums.Depth_Buffer, 0, Aliased_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Depth_Buffer;

   procedure Clear_Stencil_Buffer (Object : Framebuffer; Value : Buffers.Stencil_Index) is
      Aliased_Value : aliased Buffers.Stencil_Index := Value;
   begin
      API.Clear_Named_Framebuffer_Stencil
        (Object.Reference.GL_Id, Enums.Stencil_Buffer, 0, Aliased_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Stencil_Buffer;

   procedure Clear_Depth_And_Stencil_Buffer (Object : Framebuffer;
                                             Depth_Value   : Buffers.Depth;
                                             Stencil_Value : Buffers.Stencil_Index) is
   begin
      API.Clear_Named_Framebuffer_Depth_Stencil
        (Object.Reference.GL_Id, Enums.Depth_Stencil_Buffer, 0, Depth_Value, Stencil_Value);
      Raise_Exception_On_OpenGL_Error;
   end Clear_Depth_And_Stencil_Buffer;

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

   type Default_Framebuffer_Type is new Framebuffer with null record;

   overriding
   procedure Initialize_Id (Object : in out Default_Framebuffer_Type) is null;

   overriding
   procedure Delete_Id (Object : in out Default_Framebuffer_Type) is null;

   Default_FB : constant Default_Framebuffer_Type
     := Default_Framebuffer_Type'(GL_Object with null record);

   function Default_Framebuffer return Framebuffer is (Framebuffer (Default_FB));

end GL.Objects.Framebuffers;

gl: Fix procedure Set_Draw_Buffer in package GL.Objects.Framebuffers

The first index must be set to the given selector and all other indices
to None.

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


-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  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 Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302, "Get status is invalid");

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

end Util.Http.Clients.Tests;

-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  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 Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302, "Get status is invalid");

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

end Util.Http.Clients.Tests;

Fix the implementation of the post server unit test


-----------------------------------------------------------------------
--  util-xunit - Unit tests on top of AUnit
--  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.
-----------------------------------------------------------------------

with AUnit;
with AUnit.Simple_Test_Cases;
with AUnit.Test_Suites;
with AUnit.Test_Fixtures;
with Ada.Strings.Unbounded;

with GNAT.Source_Info;

--  The <b>Util.XUnit</b> package exposes a common package definition used by the Ada testutil
--  library.  It is intended to hide the details of the AUnit implementation.
--  A quite identical package exist for Ahven implementation.
package Util.XUnit is

   use Ada.Strings.Unbounded;
   use AUnit.Test_Suites;

   subtype Status is AUnit.Status;

   Success : constant Status := AUnit.Success;
   Failure : constant Status := AUnit.Failure;

   subtype Message_String is AUnit.Message_String;
   subtype Test_Suite is AUnit.Test_Suites.Test_Suite;
   subtype Access_Test_Suite is AUnit.Test_Suites.Access_Test_Suite;

   function Format (S : in String) return Message_String renames AUnit.Format;

   type Test_Case is abstract new AUnit.Simple_Test_Cases.Test_Case with null record;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   type Test is abstract new AUnit.Test_Fixtures.Test_Fixture with null record;

   --  maybe_overriding
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   generic
      with function Suite return Access_Test_Suite;
   procedure Harness (Output : in Ada.Strings.Unbounded.Unbounded_String;
                      XML    : in Boolean;
                      Result : out Status);

end Util.XUnit;

-----------------------------------------------------------------------
--  util-xunit - Unit tests on top of AUnit
--  Copyright (C) 2009, 2010, 2011, 2019 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 AUnit;
with AUnit.Simple_Test_Cases;
with AUnit.Test_Suites;
with AUnit.Test_Fixtures;
with Ada.Strings.Unbounded;

with GNAT.Source_Info;

--  The <b>Util.XUnit</b> package exposes a common package definition used by the Ada testutil
--  library.  It is intended to hide the details of the AUnit implementation.
--  A quite identical package exist for Ahven implementation.
package Util.XUnit is

   use Ada.Strings.Unbounded;
   use AUnit.Test_Suites;

   subtype Status is AUnit.Status;

   Success : constant Status := AUnit.Success;
   Failure : constant Status := AUnit.Failure;

   subtype Message_String is AUnit.Message_String;
   subtype Test_Suite is AUnit.Test_Suites.Test_Suite;
   subtype Access_Test_Suite is AUnit.Test_Suites.Access_Test_Suite;

   function Format (S : in String) return Message_String renames AUnit.Format;

   type Test_Case is abstract new AUnit.Simple_Test_Cases.Test_Case with null record;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   type Test is abstract new AUnit.Test_Fixtures.Test_Fixture with null record;

   --  maybe_overriding
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   generic
      with function Suite return Access_Test_Suite;
   procedure Harness (Output : in String;
                      XML    : in Boolean;
                      Label  : in String;
                      Result : out Status);

end Util.XUnit;

Add Label parameter to Harness procedure