-----------------------------------------------------------------------
--  gen-commands-page -- Page 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 Util.Strings;

package body Gen.Commands.Page is

   --  ------------------------------
   --  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);
      use Ada.Strings.Unbounded;

      function Get_Layout return String;
      function Get_Name return String;

      Dir    : constant String := Generator.Get_Result_Directory & "web/";

      function Get_Name return String is
         Name : constant String := Args.Get_Argument (1);
         Pos  : constant Natural := Util.Strings.Rindex (Name, '.');
      begin
         if Pos = 0 then
            return Name;
         elsif Name (Pos .. Name'Last) = ".xhtml" then
            return Name (Name'First .. Pos - 1);
         elsif Name (Pos .. Name'Last) = ".html" then
            return Name (Name'First .. Pos - 1);
         else
            return Name;
         end if;
      end Get_Name;

      function Get_Layout return String is
      begin
         if Args.Get_Count = 1 then
            return "layout";
         end if;
         declare
            Layout : constant String := Args.Get_Argument (2);
         begin
            if Ada.Directories.Exists (Dir & "WEB-INF/layouts/" & Layout & ".xhtml") then
               return Layout;
            end if;

            Generator.Info ("Layout file {0} not found.", Layout);
            return Layout;
         end;
      end Get_Layout;

   begin
      if Args.Get_Count = 0 or Args.Get_Count > 2 then
         Gen.Commands.Usage;
         return;
      end if;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Dir);
      Generator.Set_Global ("pageName", Get_Name);
      Generator.Set_Global ("layout", Get_Layout);
      Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "page");
   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);
      use Ada.Text_IO;
      use Ada.Directories;

      Path    : constant String := Generator.Get_Result_Directory & "web/WEB-INF/layouts";
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Search  : Search_Type;
      Ent     : Directory_Entry_Type;
   begin
      Put_Line ("add-page: Add a new web page to the application");
      Put_Line ("Usage: add-page NAME [LAYOUT]");
      New_Line;
      Put_Line ("  The web page is an XHTML file created under the 'web' directory.");
      Put_Line ("  The NAME can contain a directory that will be created if necessary.");
      Put_Line ("  The new web page can be configured to use the given layout.");
      Put_Line ("  The layout file must exist to be used.  The default layout is 'layout'.");
      Put_Line ("  You can create a new layout with 'add-layout' command.");
      Put_Line ("  You can also write your layout by adding an XHTML file in the directory:");
      Put_Line ("     " & Path);
      if Exists (Path) then
         New_Line;
         Put_Line ("  Available layouts:");

         Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name   : constant String := Simple_Name (Ent);
               Layout : constant String := Base_Name (Name);
            begin
               Put_Line ("      " & Layout);
            end;
         end loop;
      end if;
      New_Line;
      Put_Line ("  The following files are generated:");
      Put_Line ("    web/<name>.xhtml");
   end Help;

end Gen.Commands.Page;

-----------------------------------------------------------------------
--  gen-commands-page -- Page 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 Util.Strings;

package body Gen.Commands.Page is

   --  ------------------------------
   --  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);
      use Ada.Strings.Unbounded;

      function Get_Layout return String;
      function Get_Name return String;

      Dir    : constant String := Generator.Get_Result_Directory & "web/";

      function Get_Name return String is
         Name : constant String := Args.Get_Argument (1);
         Pos  : constant Natural := Util.Strings.Rindex (Name, '.');
      begin
         if Pos = 0 then
            return Name;
         elsif Name (Pos .. Name'Last) = ".xhtml" then
            return Name (Name'First .. Pos - 1);
         elsif Name (Pos .. Name'Last) = ".html" then
            return Name (Name'First .. Pos - 1);
         else
            return Name;
         end if;
      end Get_Name;

      function Get_Layout return String is
      begin
         if Args.Get_Count = 1 then
            return "layout";
         end if;
         declare
            Layout : constant String := Args.Get_Argument (2);
         begin
            if Ada.Directories.Exists (Dir & "WEB-INF/layouts/" & Layout & ".xhtml") then
               return Layout;
            end if;

            Generator.Info ("Layout file {0} not found.", Layout);
            return Layout;
         end;
      end Get_Layout;

   begin
      if Args.Get_Count = 0 or Args.Get_Count > 2 then
         Gen.Commands.Usage;
         return;
      end if;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Dir);
      Generator.Set_Global ("pageName", Get_Name);
      Generator.Set_Global ("layout", Get_Layout);
      Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "page");
   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);
      use Ada.Text_IO;
      use Ada.Directories;

      Path    : constant String := Generator.Get_Result_Directory & "web/WEB-INF/layouts";
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Search  : Search_Type;
      Ent     : Directory_Entry_Type;
   begin
      Put_Line ("add-page: Add a new web page to the application");
      Put_Line ("Usage: add-page NAME [LAYOUT]");
      New_Line;
      Put_Line ("  The web page is an XHTML file created under the 'web' directory.");
      Put_Line ("  The NAME can contain a directory that will be created if necessary.");
      Put_Line ("  The new web page can be configured to use the given layout.");
      Put_Line ("  The layout file must exist to be used.  The default layout is 'layout'.");
      Put_Line ("  You can create a new layout with 'add-layout' command.");
      Put_Line ("  You can also write your layout by adding an XHTML file in the directory:");
      Put_Line ("     " & Path);
      if Exists (Path) then
         New_Line;
         Put_Line ("  Available layouts:");

         Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name   : constant String := Simple_Name (Ent);
               Layout : constant String := Base_Name (Name);
            begin
               Put_Line ("      " & Layout);
            end;
         end loop;
      end if;
      New_Line;
      Put_Line ("  The following files are generated:");
      Put_Line ("    web/<name>.xhtml");
   end Help;

end Gen.Commands.Page;

Fix compilation warning

Fix compilation warning


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

with Util.Measures;
with Util.Log.Loggers;
with Util.Test_Caller;

with EL.Contexts.Default;
package body ASF.Routes.Tests is

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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (fixed path)",
                       Test_Add_Route_With_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (:param path)",
                       Test_Add_Route_With_Param'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (*.ext path)",
                       Test_Add_Route_With_Ext'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (#{} path)",
                       Test_Add_Route_With_EL'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Iterate",
                       Test_Iterate'Access);
   end Add_Tests;

   overriding
   function Get_Value (Bean : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Bean.Id);
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   overriding
   procedure Set_Value (Bean  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" then
         Bean.Id := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "name" then
         Bean.Name := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Bean := new Test_Bean;
      ASF.Tests.EL_Test (T).Set_Up;
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("user"),
                                Util.Beans.Objects.To_Object (T.Bean.all'Access));
      for I in T.Routes'Range loop
         T.Routes (I) := new Test_Route_Type '(Index => I);
      end loop;
   end Set_Up;

   --  ------------------------------
   --  Verify that the path matches the given route.
   --  ------------------------------
   procedure Verify_Route (T      : in out Test;
                           Router : in out Router_Type;
                           Path   : in String;
                           Index  : in Positive;
                           Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
      R       : Route_Context_Type;
   begin
      Router.Find_Route (Path, R);
      declare
         P : constant String := Get_Path (R);
      begin
         T.Assert_Equals (Path, P, "Add_Route + Find_Route with " & Path);
         T.Assert (Get_Route (R) /= null, "Get_Route returns a null route for " & Path);
         T.Assert (Get_Route (R) = Route, "Get_Route returns a wrong route for " & Path);

         --  Inject the path parameters in the bean instance.
         Inject_Parameters (R, Bean, T.ELContext.all);
      end;
   end Verify_Route;

   --  ------------------------------
   --  Add the route associted with the path pattern.
   --  ------------------------------
   procedure Add_Route (T      : in out Test;
                        Router : in out Router_Type;
                        Path   : in String;
                        Index  : in Positive;
                        Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
   begin
      Router.Add_Route (Path, Route, T.ELContext.all);
      Verify_Route (T, Router, Path, Index, Bean);
   end Add_Route;

   --  ------------------------------
   --  Test the Add_Route with simple fixed path components.
   --  Example: /list/index.html
   --  ------------------------------
   procedure Test_Add_Route_With_Path (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/page.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);

      Verify_Route (T, Router, "/list/index.html", 3, Bean);
   end Test_Add_Route_With_Path;

   --  ------------------------------
   --  Test the Add_Route with extension mapping.
   --  Example: /list/*.html
   --  ------------------------------
   procedure Test_Add_Route_With_Ext (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/*.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/page1.html", 4, Bean);
      Add_Route (T, Router, "/view/page/content/page2.html", 5, Bean);
      Add_Route (T, Router, "/view/page/content/*.html", 6, Bean);
      Add_Route (T, Router, "/ajax/*", 7, Bean);

      --  Verify precedence and wildcard matching.
      Verify_Route (T, Router, "/list/index.html", 3, Bean);
      Verify_Route (T, Router, "/list/admin.html", 2, Bean);
      Verify_Route (T, Router, "/list/1/2/3/admin.html", 2, Bean);
      Verify_Route (T, Router, "/view/page/content/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/2/t.html", 6, Bean);
      Verify_Route (T, Router, "/ajax/form/save", 7, Bean);
   end Test_Add_Route_With_Ext;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and path parameters.
   --  Example: /users/:id/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_Param (T : in out Test) is
      use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/users/:id/view.html", 1, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/list.html", 2, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/index.html", 3, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);
      T.Assert_Equals ("", To_String (Bean.Id), "Bean injection failed for fixed path");

      Add_Route (T, Router, "/users/:id/:name/index.html", 7, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals (":name", To_String (Bean.Name), "Bean injection failed for :name");

      Add_Route (T, Router, "/users/list/index.html", 8, Bean);

      Verify_Route (T, Router, "/users/1234/view.html", 1, Bean);
      T.Assert_Equals ("1234", To_String (Bean.Id), "Bean injection failed for :id");

      Verify_Route (T, Router, "/users/234/567/index.html", 7, Bean);
      T.Assert_Equals ("234", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_Param;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and EL path injection.
   --  Example: /users/#{user.id}/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_EL (T : in out Test) is
            use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : aliased Test_Bean;
   begin
      Add_Route (T, Router, "/users/#{user.id}", 1, Bean);
      Add_Route (T, Router, "/users/view.html", 2, Bean);
      Add_Route (T, Router, "/users/#{user.id}/#{user.name}/index.html", 3, Bean);
      Add_Route (T, Router, "/users/admin/#{user.id}/pages/#{user.name}", 4, Bean);

      --  Verify that the path parameters are injected in the 'user' bean (= T.Bean).
      Verify_Route (T, Router, "/users/234/567/index.html", 3, Bean);
      T.Assert_Equals ("234", To_String (T.Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (T.Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_EL;

   P_1 : aliased constant String := "/list/index.html";
   P_2 : aliased constant String := "/users/:id";
   P_3 : aliased constant String := "/users/:id/view";
   P_4 : aliased constant String := "/users/index.html";
   P_5 : aliased constant String := "/users/:id/:name";
   P_6 : aliased constant String := "/users/:id/:name/view.html";
   P_7 : aliased constant String := "/users/:id/list";
   P_8 : aliased constant String := "/users/test.html";
   P_9 : aliased constant String := "/admin/1/2/3/4/5/list.html";
   P_10 : aliased constant String := "/admin/*.html";
   P_11 : aliased constant String := "/admin/*.png";
   P_12 : aliased constant String := "/admin/*.jpg";
   P_13 : aliased constant String := "/users/:id/page/*.xml";
   P_14 : aliased constant String := "/*.jsf";

   type Const_String_Access is access constant String;

   type String_Array is array (Positive range <>) of Const_String_Access;

   Path_Array : constant String_Array :=
     (P_1'Access, P_2'Access, P_3'Access, P_4'Access,
      P_5'Access, P_6'Access, P_7'Access, P_8'Access,
      P_9'Access, P_10'Access, P_11'Access, P_12'Access,
      P_13'Access, P_14'Access);

   --  ------------------------------
   --  Test the Iterate over several paths.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;

      procedure Process (Pattern : in String;
                         Route   : in Route_Type_Access) is
      begin
         T.Assert (Route /= null, "The route is null for " & Pattern);
         T.Assert (Route.all in Test_Route_Type'Class, "Invalid route for " & Pattern);

         Log.Info ("Route {0} to {1}", Pattern, Natural'Image (Test_Route_Type (Route.all).Index));
         T.Assert_Equals (Pattern, Path_Array (Test_Route_Type (Route.all).Index).all,
                          "Invalid route for " & Pattern);
      end Process;

   begin
      for I in Path_Array'Range loop
         Add_Route (T, Router, Path_Array (I).all, I, Bean);
      end loop;
      Router.Iterate (Process'Access);

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.html", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (fixed path)");
      end;

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.jsf", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (extension)");
      end;
   end Test_Iterate;

end ASF.Routes.Tests;

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

with Util.Measures;
with Util.Log.Loggers;
with Util.Test_Caller;

with EL.Contexts.Default;
package body ASF.Routes.Tests is

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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (fixed path)",
                       Test_Add_Route_With_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (:param path)",
                       Test_Add_Route_With_Param'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (*.ext path)",
                       Test_Add_Route_With_Ext'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (#{} path)",
                       Test_Add_Route_With_EL'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Iterate",
                       Test_Iterate'Access);
   end Add_Tests;

   overriding
   function Get_Value (Bean : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Bean.Id);
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   overriding
   procedure Set_Value (Bean  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" then
         Bean.Id := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "name" then
         Bean.Name := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Bean := new Test_Bean;
      ASF.Tests.EL_Test (T).Set_Up;
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("user"),
                                Util.Beans.Objects.To_Object (T.Bean.all'Access));
      for I in T.Routes'Range loop
         T.Routes (I) := new Test_Route_Type '(Index => I);
      end loop;
   end Set_Up;

   --  ------------------------------
   --  Verify that the path matches the given route.
   --  ------------------------------
   procedure Verify_Route (T      : in out Test;
                           Router : in out Router_Type;
                           Path   : in String;
                           Index  : in Positive;
                           Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
      R       : Route_Context_Type;
   begin
      Router.Find_Route (Path, R);
      declare
         P : constant String := Get_Path (R);
      begin
         T.Assert_Equals (Path, P, "Add_Route + Find_Route with " & Path);
         T.Assert (Get_Route (R) /= null, "Get_Route returns a null route for " & Path);
         T.Assert (Get_Route (R) = Route, "Get_Route returns a wrong route for " & Path);

         --  Inject the path parameters in the bean instance.
         Inject_Parameters (R, Bean, T.ELContext.all);
      end;
   end Verify_Route;

   --  ------------------------------
   --  Add the route associted with the path pattern.
   --  ------------------------------
   procedure Add_Route (T      : in out Test;
                        Router : in out Router_Type;
                        Path   : in String;
                        Index  : in Positive;
                        Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
   begin
      Router.Add_Route (Path, Route, T.ELContext.all);
      Verify_Route (T, Router, Path, Index, Bean);
   end Add_Route;

   --  ------------------------------
   --  Test the Add_Route with simple fixed path components.
   --  Example: /list/index.html
   --  ------------------------------
   procedure Test_Add_Route_With_Path (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/page.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);

      Verify_Route (T, Router, "/list/index.html", 3, Bean);
   end Test_Add_Route_With_Path;

   --  ------------------------------
   --  Test the Add_Route with extension mapping.
   --  Example: /list/*.html
   --  ------------------------------
   procedure Test_Add_Route_With_Ext (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/*.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/page1.html", 4, Bean);
      Add_Route (T, Router, "/view/page/content/page2.html", 5, Bean);
      Add_Route (T, Router, "/view/page/content/*.html", 6, Bean);
      Add_Route (T, Router, "/ajax/*", 7, Bean);
      Add_Route (T, Router, "*.html", 8, Bean);

      --  Verify precedence and wildcard matching.
      Verify_Route (T, Router, "/list/index.html", 3, Bean);
      Verify_Route (T, Router, "/list/admin.html", 2, Bean);
      Verify_Route (T, Router, "/list/1/2/3/admin.html", 2, Bean);
      Verify_Route (T, Router, "/view/page/content/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/2/t.html", 6, Bean);
      Verify_Route (T, Router, "/ajax/form/save", 7, Bean);
      Verify_Route (T, Router, "/view/index.html", 8, Bean);
   end Test_Add_Route_With_Ext;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and path parameters.
   --  Example: /users/:id/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_Param (T : in out Test) is
      use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/users/:id/view.html", 1, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/list.html", 2, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/index.html", 3, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);
      T.Assert_Equals ("", To_String (Bean.Id), "Bean injection failed for fixed path");

      Add_Route (T, Router, "/users/:id/:name/index.html", 7, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals (":name", To_String (Bean.Name), "Bean injection failed for :name");

      Add_Route (T, Router, "/users/list/index.html", 8, Bean);

      Verify_Route (T, Router, "/users/1234/view.html", 1, Bean);
      T.Assert_Equals ("1234", To_String (Bean.Id), "Bean injection failed for :id");

      Verify_Route (T, Router, "/users/234/567/index.html", 7, Bean);
      T.Assert_Equals ("234", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_Param;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and EL path injection.
   --  Example: /users/#{user.id}/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_EL (T : in out Test) is
            use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : aliased Test_Bean;
   begin
      Add_Route (T, Router, "/users/#{user.id}", 1, Bean);
      Add_Route (T, Router, "/users/view.html", 2, Bean);
      Add_Route (T, Router, "/users/#{user.id}/#{user.name}/index.html", 3, Bean);
      Add_Route (T, Router, "/users/admin/#{user.id}/pages/#{user.name}", 4, Bean);

      --  Verify that the path parameters are injected in the 'user' bean (= T.Bean).
      Verify_Route (T, Router, "/users/234/567/index.html", 3, Bean);
      T.Assert_Equals ("234", To_String (T.Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (T.Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_EL;

   P_1 : aliased constant String := "/list/index.html";
   P_2 : aliased constant String := "/users/:id";
   P_3 : aliased constant String := "/users/:id/view";
   P_4 : aliased constant String := "/users/index.html";
   P_5 : aliased constant String := "/users/:id/:name";
   P_6 : aliased constant String := "/users/:id/:name/view.html";
   P_7 : aliased constant String := "/users/:id/list";
   P_8 : aliased constant String := "/users/test.html";
   P_9 : aliased constant String := "/admin/1/2/3/4/5/list.html";
   P_10 : aliased constant String := "/admin/*.html";
   P_11 : aliased constant String := "/admin/*.png";
   P_12 : aliased constant String := "/admin/*.jpg";
   P_13 : aliased constant String := "/users/:id/page/*.xml";
   P_14 : aliased constant String := "/*.jsf";

   type Const_String_Access is access constant String;

   type String_Array is array (Positive range <>) of Const_String_Access;

   Path_Array : constant String_Array :=
     (P_1'Access, P_2'Access, P_3'Access, P_4'Access,
      P_5'Access, P_6'Access, P_7'Access, P_8'Access,
      P_9'Access, P_10'Access, P_11'Access, P_12'Access,
      P_13'Access, P_14'Access);

   --  ------------------------------
   --  Test the Iterate over several paths.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;

      procedure Process (Pattern : in String;
                         Route   : in Route_Type_Access) is
      begin
         T.Assert (Route /= null, "The route is null for " & Pattern);
         T.Assert (Route.all in Test_Route_Type'Class, "Invalid route for " & Pattern);

         Log.Info ("Route {0} to {1}", Pattern, Natural'Image (Test_Route_Type (Route.all).Index));
         T.Assert_Equals (Pattern, Path_Array (Test_Route_Type (Route.all).Index).all,
                          "Invalid route for " & Pattern);
      end Process;

   begin
      for I in Path_Array'Range loop
         Add_Route (T, Router, Path_Array (I).all, I, Bean);
      end loop;
      Router.Iterate (Process'Access);

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.html", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (fixed path)");
      end;

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.jsf", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (extension)");
      end;
   end Test_Iterate;

end ASF.Routes.Tests;

Add a wildcard route test

Add a wildcard route test


-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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.Directories;
with Util.Test_Caller;
package body Util.Files.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File_Missing'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
         end if;
         Last := To_Unbounded_String (Dir);
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;a", Check_Path'Access, Ada.Strings.Backward);
      Assert_Equals (T, "de", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/sys/processes/os-none",
                     Compose_Path ("src;regtests;src/sys/processes", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

end Util.Files.Tests;

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

with System;
with Ada.Directories;
with Util.Systems.Constants;
with Util.Test_Caller;
package body Util.Files.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File_Missing'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Delete_Tree",
                       Test_Delete_Tree'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
         end if;
         Last := To_Unbounded_String (Dir);
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;a", Check_Path'Access, Ada.Strings.Backward);
      Assert_Equals (T, "de", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/sys/processes/os-none",
                     Compose_Path ("src;regtests;src/sys/processes", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

   function Sys_Symlink (Target : in System.Address; Link : in System.Address) return Integer
     with Import => True, Convention => C,
          Link_Name => Util.Systems.Constants.SYMBOL_PREFIX & "symlink";
   pragma Weak_External (Sys_Symlink);

   --  ------------------------------
   --  Test the Delete_Tree operation.
   --  ------------------------------
   procedure Test_Delete_Tree (T : in out Test) is
      use type System.Address;

      Path : constant String := Util.Tests.Get_Test_Path ("test-delete-tree");
   begin
      if Ada.Directories.Exists (Path) then
         Delete_Tree (Path);
      end if;

      --  Create a directory tree with symlink links that point to a non-existing file.
      Ada.Directories.Create_Directory (Path);
      for I in 1 .. 10 loop
         declare
            P : constant String := Compose (Path, Util.Strings.Image (I));
            S : String (1 .. P'Length + 3);
            R : Integer;
         begin
            Ada.Directories.Create_Directory (P);
            S (1 .. P'Length) := P;
            S (P'Length + 1) := '/';
            S (P'Length + 2) := 'A';
            S (S'Last) := ASCII.NUL;
            for J in 1 .. 5 loop
               Ada.Directories.Create_Path (Compose (P, Util.Strings.Image (J)));
            end loop;
            if Sys_Symlink'Address /= System.Null_Address then
               R := Sys_Symlink (S'Address, S'Address);
            end if;
         end;
      end loop;
      T.Assert (Ada.Directories.Exists (Path), "Directory must exist");

      --  Ada.Directories.Delete_Tree (Path) fails to delete the tree.
      Delete_Tree (Path);
      T.Assert (not Ada.Directories.Exists (Path), "Directory must have been deleted");
   end Test_Delete_Tree;

end Util.Files.Tests;

Add Test_Delete_Tree and register the new test for execution The new test creates a directory tree with several symbolic links to missing files. The Ada.Directories.Delete_Tree procedure fails but the Util.Files.Delete_Tree must succeed.


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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Services.Tests;
with AWA.Wikis.Parsers.Tests;
with AWA.Wikis.Writers.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Questions.Services.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;

with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Wikis.Parsers.Tests.Add_Tests (Ret);
      AWA.Wikis.Writers.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Blogs.Services.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Services.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Application.Start;
            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Services.Tests;
with AWA.Wikis.Parsers.Tests;
with AWA.Wikis.Writers.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;

with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Wikis.Parsers.Tests.Add_Tests (Ret);
      AWA.Wikis.Writers.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Blogs.Services.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Application.Start;
            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

Update the testsuite

Update the testsuite


-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 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 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.Applications;
package body AWA.Modules is

   --  ------------------------------
   --  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 <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;

   --  ------------------------------
   --  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
   begin
      return Manager.App.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
   begin
      return Manager.App.Get_Master_Session;
   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;

   --  ------------------------------
   --  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 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.Applications;
package body AWA.Modules is

   --  ------------------------------
   --  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 <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;

   --  ------------------------------
   --  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
   begin
      return Manager.App.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
   begin
      return Manager.App.Get_Master_Session;
   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;

Implement the Add_Listener procedure

Implement the Add_Listener procedure