-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  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 Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  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 Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  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 Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  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 Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Declare the Frame_Information procedure and protected operation


-----------------------------------------------------------------------
--  awa-modules-tests - Unit tests for Modules
--  Copyright (C) 2011, 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.Beans.Basic;
with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Main;
with AWA.Modules.Beans;
with AWA.Services.Contexts;
package body AWA.Modules.Tests is

   use Util.Tests;

   type Test_Module is new AWA.Modules.Module with null record;
   type Test_Module_Access is access all Test_Module'Class;

   type Test_Bean is new Util.Beans.Basic.Bean with record
      Module : Test_Module_Access := null;
      Name   : Util.Beans.Objects.Object;
      Email  : Util.Beans.Objects.Object;
   end record;
   type Test_Bean_Access is access all Test_Bean'Class;

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

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   function Create_Form_Bean (Plugin : in Test_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   package Module_Register is new AWA.Modules.Beans (Test_Module, Test_Module_Access);

   package Caller is new Util.Test_Caller (Test, "AWA.Modules");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Modules.Register",
                       Test_Create_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Modules.Find_Module",
                       Test_Find_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register",
                       Test_Create_Application_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Application_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Navigations.Mappers",
                       Test_Module_Navigation'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "module" then
         return Util.Beans.Objects.To_Object (From.Module.Get_Name);
      elsif Name = "name" then
         return From.Name;
      elsif Name = "email" then
         return From.Email;
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Name := Value;
      elsif Name = "email" then
         From.Email := Value;
      end if;
   end Set_Value;

   function Create_Form_Bean (Plugin : in Test_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Test_Bean_Access := new Test_Bean;
   begin
      Result.Module := Plugin;
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      Log.Info ("Creating application");
      T.App := new AWA.Applications.Application;
      C.Copy (Util.Tests.Get_Properties);
      C.Set ("app_search_dirs", Util.Tests.Get_Path ("regtests") & ";"
             & C.Get ("app_search_dirs", ""));
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                         Name   => AWA.Applications.Application_Access);
   begin
      Log.Info ("Releasing application");
      Free (T.App);
   end Tear_Down;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Create_Module (T : in out Test) is
      M   : aliased Test_Module;
      R   : aliased Module_Registry;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      R.Config.Copy (Util.Tests.Get_Properties);
      M.App := T.App.all'Access;
      Register (R'Unchecked_Access, M.App, M'Unchecked_Access, "empty", "uri");

      T.Assert_Equals ("empty", M.Get_Name, "Invalid module name");
      T.Assert_Equals ("uri", M.Get_URI, "Invalid module uri");

      T.Assert (Find_By_Name (R, "empty") = M'Unchecked_Access, "Find_By_Name failed");
      T.Assert (Find_By_URI (R, "uri") = M'Unchecked_Access, "Find_By_URI failed");
   end Test_Create_Module;

   --  ------------------------------
   --  Test looking for module
   --  ------------------------------
   procedure Test_Find_Module (T : in out Test) is
      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      T.App.Register (M'Unchecked_Access, "empty", "uri");

      T.Assert (M.Find_Module ("empty") /= null, "Find_Module should not return a null value");
      T.Assert (M.Find_Module ("toto") = null, "Find_Module should return null");
   end Test_Find_Module;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Application_Module (T : in out Test) is
      use ASF.Beans;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         T.Assert_Equals ("test-module",
                          Util.Beans.Objects.To_String (Bean.Get_Value ("module")),
                          "Bean module name");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      Module_Register.Register (Plugin  => M,
                                Name    => "ASF.Applications.Tests.Form_Bean",
                                Handler => Create_Form_Bean'Access);
      T.App.Register (M'Unchecked_Access, "test-module", "uri");

      T.Assert (M.Find_Module ("test-module") /= null,
                "Find_Module should not return a null value");
      T.Assert (M.Find_Module ("toto") = null, "Find_Module should return null");

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Application_Module;

   --  ------------------------------
   --  Test module and navigation rules
   --  ------------------------------
   procedure Test_Module_Navigation (T : in out Test) is
      use ASF.Beans;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      Module_Register.Register (Plugin  => M,
                                Name    => "ASF.Applications.Tests.Form_Bean",
                                Handler => Create_Form_Bean'Access);
      T.App.Register (M'Unchecked_Access, "test-navigations", "uri");

      T.Assert (M.Find_Module ("test-navigations") /= null,
                "Find_Module should not return a null value");

   end Test_Module_Navigation;

end AWA.Modules.Tests;

-----------------------------------------------------------------------
--  awa-modules-tests - Unit tests for Modules
--  Copyright (C) 2011, 2012, 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 Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Main;
with AWA.Modules.Beans;
with AWA.Services.Contexts;
package body AWA.Modules.Tests is

   use Util.Tests;

   type Test_Module is new AWA.Modules.Module with null record;
   type Test_Module_Access is access all Test_Module'Class;

   type Test_Bean is new Util.Beans.Basic.Bean with record
      Module : Test_Module_Access := null;
      Name   : Util.Beans.Objects.Object;
      Email  : Util.Beans.Objects.Object;
   end record;
   type Test_Bean_Access is access all Test_Bean'Class;

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

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   function Create_Form_Bean (Plugin : in Test_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   package Module_Register is new AWA.Modules.Beans (Test_Module, Test_Module_Access);

   package Caller is new Util.Test_Caller (Test, "AWA.Modules");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Modules.Register",
                       Test_Create_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Modules.Find_Module",
                       Test_Find_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register",
                       Test_Create_Application_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Application_Module'Access);
      Caller.Add_Test (Suite, "Test ASF.Navigations.Mappers",
                       Test_Module_Navigation'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "module" then
         return Util.Beans.Objects.To_Object (From.Module.Get_Name);
      elsif Name = "name" then
         return From.Name;
      elsif Name = "email" then
         return From.Email;
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Name := Value;
      elsif Name = "email" then
         From.Email := Value;
      end if;
   end Set_Value;

   function Create_Form_Bean (Plugin : in Test_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Test_Bean_Access := new Test_Bean;
   begin
      Result.Module := Plugin;
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      Log.Info ("Creating application");
      T.App := new AWA.Applications.Application;
      C.Copy (Util.Tests.Get_Properties);
      C.Set ("app_search_dirs", Util.Tests.Get_Path ("regtests") & ";"
             & C.Get ("app_search_dirs", ""));
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                         Name   => AWA.Applications.Application_Access);
   begin
      Log.Info ("Releasing application");
      Free (T.App);
   end Tear_Down;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Create_Module (T : in out Test) is
      M   : aliased Test_Module;
      R   : aliased Module_Registry;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      R.Config.Copy (Util.Tests.Get_Properties);
      M.App := T.App.all'Access;
      Register (R'Unchecked_Access, M.App, M'Unchecked_Access, "empty", "uri");

      T.Assert_Equals ("empty", M.Get_Name, "Invalid module name");
      T.Assert_Equals ("uri", M.Get_URI, "Invalid module uri");

      T.Assert (Find_By_Name (R, "empty") = M'Unchecked_Access, "Find_By_Name failed");
      T.Assert (Find_By_URI (R, "uri") = M'Unchecked_Access, "Find_By_URI failed");
   end Test_Create_Module;

   --  ------------------------------
   --  Test looking for module
   --  ------------------------------
   procedure Test_Find_Module (T : in out Test) is
      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      T.App.Register (M'Unchecked_Access, "empty", "uri");

      T.Assert (M.Find_Module ("empty") /= null, "Find_Module should not return a null value");
      T.Assert (M.Find_Module ("toto") = null, "Find_Module should return null");
   end Test_Find_Module;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Application_Module (T : in out Test) is
      use ASF.Beans;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         use type Util.Beans.Basic.Readonly_Bean_Access;

         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         T.Assert_Equals ("test-module",
                          Util.Beans.Objects.To_String (Bean.Get_Value ("module")),
                          "Bean module name");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      Module_Register.Register (Plugin  => M,
                                Name    => "ASF.Applications.Tests.Form_Bean",
                                Handler => Create_Form_Bean'Access);
      T.App.Register (M'Unchecked_Access, "test-module", "uri");

      T.Assert (M.Find_Module ("test-module") /= null,
                "Find_Module should not return a null value");
      T.Assert (M.Find_Module ("toto") = null, "Find_Module should return null");

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Application_Module;

   --  ------------------------------
   --  Test module and navigation rules
   --  ------------------------------
   procedure Test_Module_Navigation (T : in out Test) is
      M   : aliased Test_Module;
      Ctx : AWA.Services.Contexts.Service_Context;
   begin
      Ctx.Set_Context (T.App, null);
      M.App := T.App.all'Access;
      Module_Register.Register (Plugin  => M,
                                Name    => "ASF.Applications.Tests.Form_Bean",
                                Handler => Create_Form_Bean'Access);
      T.App.Register (M'Unchecked_Access, "test-navigations", "uri");

      T.Assert (M.Find_Module ("test-navigations") /= null,
                "Find_Module should not return a null value");

   end Test_Module_Navigation;

end AWA.Modules.Tests;

Fix compilation warning

Fix compilation warning


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

with Util.Tests;

package Util.Events.Timers.Tests is

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

   type Test is new Util.Tests.Test
     and Util.Events.Timers.Timer with record
      Count : Natural := 0;
   end record;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class);

   --  Test empty timers.
   procedure Test_Empty_Timer (T : in out Test);

   procedure Test_Timer_Event (T : in out Test);

end Util.Events.Timers.Tests;

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

with Util.Tests;

package Util.Events.Timers.Tests is

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

   type Test is new Util.Tests.Test
     and Util.Events.Timers.Timer with record
      Count  : Natural := 0;
      Repeat : Natural := 0;
   end record;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class);

   --  Test empty timers.
   procedure Test_Empty_Timer (T : in out Test);

   procedure Test_Timer_Event (T : in out Test);

   --  Test repeating timers.
   procedure Test_Repeat_Timer (T : in out Test);

end Util.Events.Timers.Tests;

Declare the Test_Repeat_Timer procedure

Declare the Test_Repeat_Timer procedure


-----------------------------------------------------------------------
--  asf-rest -- REST Support
--  Copyright (C) 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 ASF.Routes;
with ASF.Routes.Servlets.Rest;
with ASF.Servlets.Rest;
with EL.Contexts.Default;
with Util.Log.Loggers;
package body ASF.Rest is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Rest");

   --  ------------------------------
   --  Get the permission index associated with the REST operation.
   --  ------------------------------
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index is
   begin
      return Handler.Permission;
   end Get_Permission;

   --  ------------------------------
   --  Register the API descriptor in a list.
   --  ------------------------------
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access) is
   begin
      Item.Next := List;
      List := Item;
   end Register;

   --  ------------------------------
   --  Register the list of API descriptors for a given servlet and a root path.
   --  ------------------------------
   procedure Register (Registry  : in out ASF.Servlets.Servlet_Registry;
                       Name      : in String;
                       URI       : in String;
                       ELContext : in EL.Contexts.ELContext'Class;
                       List      : in Descriptor_Access) is
      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);
      use type ASF.Routes.Route_Type_Access;
      Item : Descriptor_Access := List;

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0}/{1} already used by another page",
                          URI, Item.Pattern.all);
               return;
            end if;
            D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
         else
            D := ASF.Servlets.Rest.Create_Route (Registry, Name);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Item.Method) /= null then
            Log.Error ("Route API for {0}/{1} is already used", URI, Item.Pattern.all);
         end if;
         D.Descriptors (Item.Method) := Item;
      end Insert;

   begin
      Log.Info ("Adding API route {0}", URI);
      while Item /= null loop
         Log.Debug ("Adding API route {0}/{1}", URI, Item.Pattern.all);
         Registry.Add_Route (URI & "/" & Item.Pattern.all, ELContext, Insert'Access);
         Item := Item.Next;
      end loop;
   end Register;

   --  Dispatch the request to the API handler.
   overriding
   procedure Dispatch (Handler : in Static_Descriptor;
                       Req     : in out ASF.Rest.Request'Class;
                       Reply   : in out ASF.Rest.Response'Class;
                       Stream  : in out Output_Stream'Class) is
   begin
      Handler.Handler (Req, Reply, Stream);
   end Dispatch;

   --  Register the API definition in the servlet registry.
   procedure Register (Registry   : in out ASF.Servlets.Servlet_Registry'Class;
                       Definition : in Descriptor_Access) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Servlets.Servlet_Access;

      Dispatcher : constant ASF.Servlets.Request_Dispatcher
         := Registry.Get_Request_Dispatcher (Definition.Pattern.all);
      Servlet    : ASF.Servlets.Servlet_Access := ASF.Servlets.Get_Servlet (Dispatcher);

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0} already used by another page",
                          Definition.Pattern.all);
               D := ASF.Servlets.Rest.Create_Route (Servlet);
               Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
            else
               D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
            end if;
         else
            D := ASF.Servlets.Rest.Create_Route (Servlet);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Definition.Method) /= null then
            Log.Error ("Route API for {0} is already used", Definition.Pattern.all);
         end if;
         D.Descriptors (Definition.Method) := Definition;
      end Insert;

      Ctx     : EL.Contexts.Default.Default_Context;
   begin
      if Servlet = null then
         Log.Error ("Cannot register REST operation {0}: no REST servlet",
                    Definition.Pattern.all);
         return;
      end if;
      Registry.Add_Route (Definition.Pattern.all, Ctx, Insert'Access);
   end Register;

end ASF.Rest;

-----------------------------------------------------------------------
--  asf-rest -- REST Support
--  Copyright (C) 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.Routes;
with ASF.Routes.Servlets.Rest;
with ASF.Servlets.Rest;
with EL.Contexts.Default;
with Util.Log.Loggers;
package body ASF.Rest is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Rest");

   --  ------------------------------
   --  Get the permission index associated with the REST operation.
   --  ------------------------------
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index is
   begin
      return Handler.Permission;
   end Get_Permission;

   --  ------------------------------
   --  Register the API descriptor in a list.
   --  ------------------------------
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access) is
   begin
      Item.Next := List;
      List := Item;
   end Register;

   --  ------------------------------
   --  Register the list of API descriptors for a given servlet and a root path.
   --  ------------------------------
   procedure Register (Registry  : in out ASF.Servlets.Servlet_Registry;
                       Name      : in String;
                       URI       : in String;
                       ELContext : in EL.Contexts.ELContext'Class;
                       List      : in Descriptor_Access) is
      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);
      use type ASF.Routes.Route_Type_Access;
      Item : Descriptor_Access := List;

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0}/{1} already used by another page",
                          URI, Item.Pattern.all);
               return;
            end if;
            D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
         else
            D := ASF.Servlets.Rest.Create_Route (Registry, Name);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Item.Method) /= null then
            Log.Error ("Route API for {0}/{1} is already used", URI, Item.Pattern.all);
         end if;
         D.Descriptors (Item.Method) := Item;
      end Insert;

   begin
      Log.Info ("Adding API route {0}", URI);
      while Item /= null loop
         Log.Debug ("Adding API route {0}/{1}", URI, Item.Pattern.all);
         Registry.Add_Route (URI & "/" & Item.Pattern.all, ELContext, Insert'Access);
         Item := Item.Next;
      end loop;
   end Register;

   --  Dispatch the request to the API handler.
   overriding
   procedure Dispatch (Handler : in Static_Descriptor;
                       Req     : in out ASF.Rest.Request'Class;
                       Reply   : in out ASF.Rest.Response'Class;
                       Stream  : in out Output_Stream'Class) is
   begin
      Handler.Handler (Req, Reply, Stream);
   end Dispatch;

   --  Register the API definition in the servlet registry.
   procedure Register (Registry   : in out ASF.Servlets.Servlet_Registry'Class;
                       Definition : in Descriptor_Access) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Servlets.Servlet_Access;

      Dispatcher : constant ASF.Servlets.Request_Dispatcher
         := Registry.Get_Request_Dispatcher (Definition.Pattern.all);
      Servlet    : constant ASF.Servlets.Servlet_Access := ASF.Servlets.Get_Servlet (Dispatcher);

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0} already used by another page",
                          Definition.Pattern.all);
               D := ASF.Servlets.Rest.Create_Route (Servlet);
               Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
            else
               D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
            end if;
         else
            D := ASF.Servlets.Rest.Create_Route (Servlet);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Definition.Method) /= null then
            Log.Error ("Route API for {0} is already used", Definition.Pattern.all);
         end if;
         D.Descriptors (Definition.Method) := Definition;
      end Insert;

      Ctx     : EL.Contexts.Default.Default_Context;
   begin
      if Servlet = null then
         Log.Error ("Cannot register REST operation {0}: no REST servlet",
                    Definition.Pattern.all);
         return;
      end if;
      Registry.Add_Route (Definition.Pattern.all, Ctx, Insert'Access);
   end Register;

end ASF.Rest;

Change Servlet local variable to a constant


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

with Ada.Unchecked_Deallocation;

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

with ASF.Contexts.Faces;
with EL.Variables.Default;

package body ASF.Tests is

   use Util.Tests;

   CONTEXT_PATH : constant String := "/asfunit";

   App_Created : ASF.Applications.Main.Application_Access;
   App         : ASF.Applications.Main.Application_Access;
   Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   Ajax        : aliased ASF.Servlets.Ajax.Ajax_Servlet;
   Files       : aliased Servlet.Core.Files.File_Servlet;
   Measures    : aliased Servlet.Core.Measures.Measure_Servlet;

   --  ------------------------------
   --  Initialize the awa test framework mockup.
   --  ------------------------------
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class) is
      use type ASF.Applications.Main.Application_Access;

      C        : ASF.Applications.Config;
      Empty    : Util.Properties.Manager;
   begin
      if Application /= null then
         App := Application;
      else
         if App_Created = null then
            App_Created := new ASF.Applications.Main.Application;
         end if;
         App := App_Created;
      end if;

      C.Copy (Props);
      App.Initialize (C, Factory);
      App.Register ("layoutMsg", "layout");
      App.Set_Global ("contextPath", CONTEXT_PATH);

      --  Register the servlets and filters
      App.Add_Servlet (Name => "faces", Server => Faces'Access);
      App.Add_Servlet (Name => "ajax", Server => Ajax'Access);
      App.Add_Servlet (Name => "files", Server => Files'Access);
      App.Add_Servlet (Name => "measures", Server => Measures'Access);
      App.Add_Filter (Name => "measures",
                      Filter => Servlet.Filters.Filter'Class (Measures)'Access);

      --  Define servlet mappings
      App.Add_Mapping (Name => "faces", Pattern => "*.html");
      App.Add_Mapping (Name => "ajax", Pattern => "/ajax/*");
      App.Add_Mapping (Name => "files", Pattern => "*.css");
      App.Add_Mapping (Name => "files", Pattern => "*.js");
      App.Add_Mapping (Name => "files", Pattern => "*.html");
      App.Add_Mapping (Name => "files", Pattern => "*.txt");
      App.Add_Mapping (Name => "files", Pattern => "*.png");
      App.Add_Mapping (Name => "files", Pattern => "*.jpg");
      App.Add_Mapping (Name => "files", Pattern => "*.gif");
      App.Add_Mapping (Name => "files", Pattern => "*.pdf");
      App.Add_Mapping (Name => "files", Pattern => "*.properties");
      App.Add_Mapping (Name => "files", Pattern => "*.xhtml");
      App.Add_Mapping (Name => "measures", Pattern => "stats.xml");

      App.Add_Filter_Mapping (Name => "measures", Pattern => "*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "/ajax/*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.xhtml");

      Servlet.Tests.Initialize (Empty, CONTEXT_PATH, App.all'Access);
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return ASF.Applications.Main.Application_Access is
      use type Servlet.Core.Servlet_Registry_Access;
      Result : constant Servlet.Core.Servlet_Registry_Access := Servlet.Tests.Get_Application;
   begin
      if Result = null then
         return App;
      elsif Result.all in ASF.Applications.Main.Application'Class then
         return ASF.Applications.Main.Application'Class (Result.all)'Access;
      else
         return App;
      end if;
   end Get_Application;

   --  ------------------------------
   --  Cleanup the test instance.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out EL_Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Contexts.Default.Default_Context'Class,
                                        EL.Contexts.Default.Default_Context_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Variables.Variable_Mapper'Class,
                                        EL.Variables.Variable_Mapper_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Contexts.Default.Default_ELResolver'Class,
                                        EL.Contexts.Default.Default_ELResolver_Access);
   begin
      ASF.Contexts.Faces.Restore (null);
      Free (T.ELContext);
      Free (T.Variables);
      Free (T.Root_Resolver);
   end Tear_Down;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out EL_Test) is
   begin
      T.ELContext     := new EL.Contexts.Default.Default_Context;
      T.Root_Resolver := new EL.Contexts.Default.Default_ELResolver;
      T.Variables     := new EL.Variables.Default.Default_Variable_Mapper;
      T.ELContext.Set_Resolver (T.Root_Resolver.all'Access);
      T.ELContext.Set_Variable_Mapper (T.Variables.all'Access);
   end Set_Up;

end ASF.Tests;

-----------------------------------------------------------------------
--  asf-tests - ASF Tests Framework
--  Copyright (C) 2011, 2012, 2013, 2015, 2017, 2018, 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 Ada.Unchecked_Deallocation;

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

with ASF.Contexts.Faces;
with EL.Variables.Default;

package body ASF.Tests is

   CONTEXT_PATH : constant String := "/asfunit";

   App_Created : ASF.Applications.Main.Application_Access;
   App         : ASF.Applications.Main.Application_Access;
   Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   Ajax        : aliased ASF.Servlets.Ajax.Ajax_Servlet;
   Files       : aliased Servlet.Core.Files.File_Servlet;
   Measures    : aliased Servlet.Core.Measures.Measure_Servlet;

   --  ------------------------------
   --  Initialize the awa test framework mockup.
   --  ------------------------------
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class) is
      use type ASF.Applications.Main.Application_Access;

      C        : ASF.Applications.Config;
      Empty    : Util.Properties.Manager;
   begin
      if Application /= null then
         App := Application;
      else
         if App_Created = null then
            App_Created := new ASF.Applications.Main.Application;
         end if;
         App := App_Created;
      end if;

      C.Copy (Props);
      App.Initialize (C, Factory);
      App.Register ("layoutMsg", "layout");
      App.Set_Global ("contextPath", CONTEXT_PATH);

      --  Register the servlets and filters
      App.Add_Servlet (Name => "faces", Server => Faces'Access);
      App.Add_Servlet (Name => "ajax", Server => Ajax'Access);
      App.Add_Servlet (Name => "files", Server => Files'Access);
      App.Add_Servlet (Name => "measures", Server => Measures'Access);
      App.Add_Filter (Name => "measures",
                      Filter => Servlet.Filters.Filter'Class (Measures)'Access);

      --  Define servlet mappings
      App.Add_Mapping (Name => "faces", Pattern => "*.html");
      App.Add_Mapping (Name => "ajax", Pattern => "/ajax/*");
      App.Add_Mapping (Name => "files", Pattern => "*.css");
      App.Add_Mapping (Name => "files", Pattern => "*.js");
      App.Add_Mapping (Name => "files", Pattern => "*.html");
      App.Add_Mapping (Name => "files", Pattern => "*.txt");
      App.Add_Mapping (Name => "files", Pattern => "*.png");
      App.Add_Mapping (Name => "files", Pattern => "*.jpg");
      App.Add_Mapping (Name => "files", Pattern => "*.gif");
      App.Add_Mapping (Name => "files", Pattern => "*.pdf");
      App.Add_Mapping (Name => "files", Pattern => "*.properties");
      App.Add_Mapping (Name => "files", Pattern => "*.xhtml");
      App.Add_Mapping (Name => "measures", Pattern => "stats.xml");

      App.Add_Filter_Mapping (Name => "measures", Pattern => "*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "/ajax/*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.xhtml");

      Servlet.Tests.Initialize (Empty, CONTEXT_PATH, App.all'Access);
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return ASF.Applications.Main.Application_Access is
      use type Servlet.Core.Servlet_Registry_Access;
      Result : constant Servlet.Core.Servlet_Registry_Access := Servlet.Tests.Get_Application;
   begin
      if Result = null then
         return App;
      elsif Result.all in ASF.Applications.Main.Application'Class then
         return ASF.Applications.Main.Application'Class (Result.all)'Access;
      else
         return App;
      end if;
   end Get_Application;

   --  ------------------------------
   --  Cleanup the test instance.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out EL_Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Contexts.Default.Default_Context'Class,
                                        EL.Contexts.Default.Default_Context_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Variables.Variable_Mapper'Class,
                                        EL.Variables.Variable_Mapper_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (EL.Contexts.Default.Default_ELResolver'Class,
                                        EL.Contexts.Default.Default_ELResolver_Access);
   begin
      ASF.Contexts.Faces.Restore (null);
      Free (T.ELContext);
      Free (T.Variables);
      Free (T.Root_Resolver);
   end Tear_Down;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out EL_Test) is
   begin
      T.ELContext     := new EL.Contexts.Default.Default_Context;
      T.Root_Resolver := new EL.Contexts.Default.Default_ELResolver;
      T.Variables     := new EL.Variables.Default.Default_Variable_Mapper;
      T.ELContext.Set_Resolver (T.Root_Resolver.all'Access);
      T.ELContext.Set_Variable_Mapper (T.Variables.all'Access);
   end Set_Up;

end ASF.Tests;

Remove unused use clause

Remove unused use clause


-----------------------------------------------------------------------
--  asf.responses -- ASF Requests
--  Copyright (C) 2010, 2011, 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.
-----------------------------------------------------------------------

--  The ASF.Responses package is an Ada implementation of
--  the Java servlet response (JSR 315 5. The Response).
package body ASF.Responses.Mockup is

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
      Pos : constant Util.Strings.Maps.Cursor := Resp.Headers.Find (Name);
   begin
      return Util.Strings.Maps.Has_Element (Pos);
   end Contains_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is

      procedure Process_Wrapper (Position : in Util.Strings.Maps.Cursor);

      procedure Process_Wrapper (Position : in Util.Strings.Maps.Cursor) is
      begin
         Process.all (Name  => Util.Strings.Maps.Key (Position),
                      Value => Util.Strings.Maps.Element (Position));
      end Process_Wrapper;

   begin
      Resp.Headers.Iterate (Process => Process_Wrapper'Access);
   end Iterate_Headers;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      Resp.Headers.Include (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if Resp.Headers.Contains (Name) then
         Resp.Headers.Include (Name, Resp.Headers.Element (Name) & ASCII.LF
                               & Value);
      else
         Resp.Headers.Insert (Name, Value);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the response. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Resp : in Response;
                        Name : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Resp.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Get the content written to the mockup output stream.
   --  ------------------------------
   procedure Read_Content (Resp : in out Response;
                           Into : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Resp.Headers.Include ("Content-Type", Resp.Get_Content_Type);
      Resp.Content.Read (Into => Into);
   end Read_Content;

   --  ------------------------------
   --  Clear the response content.
   --  This operation removes any content held in the output stream, clears the status,
   --  removes any header in the response.
   --  ------------------------------
   procedure Clear (Resp : in out Response) is
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Resp.Read_Content (Content);
      Resp.Status := SC_OK;
      Resp.Headers.Clear;
   end Clear;

   --  ------------------------------
   --  Initialize the response mockup output stream.
   --  ------------------------------
   overriding
   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (128 * 1024);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

end ASF.Responses.Mockup;

-----------------------------------------------------------------------
--  asf.responses -- ASF Requests
--  Copyright (C) 2010, 2011, 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.
-----------------------------------------------------------------------

--  The ASF.Responses package is an Ada implementation of
--  the Java servlet response (JSR 315 5. The Response).
package body ASF.Responses.Mockup is

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
      Pos : constant Util.Strings.Maps.Cursor := Resp.Headers.Find (Name);
   begin
      return Util.Strings.Maps.Has_Element (Pos);
   end Contains_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is

      procedure Process_Wrapper (Position : in Util.Strings.Maps.Cursor);

      procedure Process_Wrapper (Position : in Util.Strings.Maps.Cursor) is
      begin
         Process.all (Name  => Util.Strings.Maps.Key (Position),
                      Value => Util.Strings.Maps.Element (Position));
      end Process_Wrapper;

   begin
      Resp.Headers.Iterate (Process => Process_Wrapper'Access);
   end Iterate_Headers;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      Resp.Headers.Include (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if Resp.Headers.Contains (Name) then
         Resp.Headers.Include (Name, Resp.Headers.Element (Name) & ASCII.LF
                               & Value);
      else
         Resp.Headers.Insert (Name, Value);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the response. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Resp : in Response;
                        Name : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Resp.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Get the content written to the mockup output stream.
   --  ------------------------------
   procedure Read_Content (Resp : in out Response;
                           Into : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Resp.Headers.Include ("Content-Type", Resp.Get_Content_Type);
      Resp.Content.Flush (Into);
   end Read_Content;

   --  ------------------------------
   --  Clear the response content.
   --  This operation removes any content held in the output stream, clears the status,
   --  removes any header in the response.
   --  ------------------------------
   procedure Clear (Resp : in out Response) is
      Into : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Resp.Content.Flush (Into);
      Resp.Status := SC_OK;
      Resp.Headers.Clear;
   end Clear;

   --  ------------------------------
   --  Initialize the response mockup output stream.
   --  ------------------------------
   overriding
   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (128 * 1024);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

end ASF.Responses.Mockup;

Update to use the Output_Buffer_Stream Flush operation to retrieve the output content


-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 2011, 2012, 2013, 2014, 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.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name, Args);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
      Gtk_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado -gtk") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            elsif Full_Switch = "-gtk" then
               Gtk_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag and not Gtk_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Property ("is_gtk", Boolean'Image (Gtk_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         elsif Gtk_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-gtk");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|gpl3|mit|bsd3|proprietary] [--web] [--tool]"
                & "[--ado] [--gtk] NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the MIT license, the BSD 3 clauses");
      Put_Line ("  license, the GNU licenses or a proprietary license.");
      Put_Line ("  The author's name and email addresses are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
      Put_Line ("  --gtk   Generate a GtkAda project");
   end Help;

end Gen.Commands.Project;

-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 2011, 2012, 2013, 2014, 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.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Name, Args);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
      Gtk_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado -gtk") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            elsif Full_Switch = "-gtk" then
               Gtk_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag and not Gtk_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Cmd.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Cmd.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Property ("is_gtk", Boolean'Image (Gtk_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         elsif Gtk_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-gtk");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|gpl3|mit|bsd3|proprietary] [--web] [--tool]"
                & "[--ado] [--gtk] NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the MIT license, the BSD 3 clauses");
      Put_Line ("  license, the GNU licenses or a proprietary license.");
      Put_Line ("  The author's name and email addresses are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
      Put_Line ("  --gtk   Generate a GtkAda project");
   end Help;

end Gen.Commands.Project;

Use the command usage procedure to report the program usage