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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 19, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 21, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Update the schema test after introduction of new test tables


-----------------------------------------------------------------------
--  elf -- ELF information
--  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 Interfaces;
package ELF is

   subtype Elf32_Word is Interfaces.Unsigned_32;
   subtype Elf64_Word is Interfaces.Unsigned_64;

   --  Legal values for the ELF header p_type (segment type).
   PT_NULL    : constant Elf32_Word := 0;   --  Program header table entry unused.
   PT_LOAD    : constant Elf32_Word := 1;   --  Loadable program segment
   PT_DYNAMIC : constant Elf32_Word := 2;   --  Dynamic linking information
   PT_INTERP  : constant Elf32_Word := 3;   --  Program interpreter
   PT_NOTE    : constant Elf32_Word := 4;   --  Auxiliary information
   PT_SHLIB   : constant Elf32_Word := 5;   --  Reserved
   PT_PHDR    : constant Elf32_Word := 6;   --  Entry for header table itself
   PT_TLS     : constant Elf32_Word := 7;   --  Thread-local storage segment
   PT_NUM     : constant Elf32_Word := 8;   --  Number of defined types
   PT_LOOS    : constant Elf32_Word := 16#60000000#;       --  Start of OS-specific
   PT_GNU_EH_FRAME : constant Elf32_Word := 16#6474e550#;  --  GCC .eh_frame_hdr segment
   PT_GNU_STACK    : constant Elf32_Word := 16#6474e551#;  --  Indicates stack executability
   PT_GNU_RELRO    : constant Elf32_Word := 16#6474e552#;  --  Read-only after relocation
   PT_LOSUNW       : constant Elf32_Word := 16#6ffffffa#;
   PT_SUNWBSS      : constant Elf32_Word := 16#6ffffffa#;  --  Sun Specific segment
   PT_SUNWSTACK    : constant Elf32_Word := 16#6ffffffb#;  --  Stack segment
   PT_HISUNW       : constant Elf32_Word := 16#6fffffff#;
   PT_HIOS         : constant Elf32_Word := 16#6fffffff#;  --  End of OS-specific
   PT_LOPROC       : constant Elf32_Word := 16#70000000#;  --  Start of processor-specific
   PT_HIPROC       : constant Elf32_Word := 16#7fffffff#;  --  End of processor-specific

   --  Legal values for ELF header p_flags (segment flags).
   PF_X        : constant Elf32_Word := 1;  --  Segment is executable.
   PF_W        : constant Elf32_Word := 2;  --  Segment is writable.
   PF_R        : constant Elf32_Word := 4;  --  Segment is readable.

end ELF;

-----------------------------------------------------------------------
--  elf -- ELF information
--  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 Interfaces;
package ELF is

   pragma Preelaborate;

   subtype Elf32_Word is Interfaces.Unsigned_32;
   subtype Elf64_Word is Interfaces.Unsigned_64;

   --  Legal values for the ELF header p_type (segment type).
   PT_NULL    : constant Elf32_Word := 0;   --  Program header table entry unused.
   PT_LOAD    : constant Elf32_Word := 1;   --  Loadable program segment
   PT_DYNAMIC : constant Elf32_Word := 2;   --  Dynamic linking information
   PT_INTERP  : constant Elf32_Word := 3;   --  Program interpreter
   PT_NOTE    : constant Elf32_Word := 4;   --  Auxiliary information
   PT_SHLIB   : constant Elf32_Word := 5;   --  Reserved
   PT_PHDR    : constant Elf32_Word := 6;   --  Entry for header table itself
   PT_TLS     : constant Elf32_Word := 7;   --  Thread-local storage segment
   PT_NUM     : constant Elf32_Word := 8;   --  Number of defined types
   PT_LOOS    : constant Elf32_Word := 16#60000000#;       --  Start of OS-specific
   PT_GNU_EH_FRAME : constant Elf32_Word := 16#6474e550#;  --  GCC .eh_frame_hdr segment
   PT_GNU_STACK    : constant Elf32_Word := 16#6474e551#;  --  Indicates stack executability
   PT_GNU_RELRO    : constant Elf32_Word := 16#6474e552#;  --  Read-only after relocation
   PT_LOSUNW       : constant Elf32_Word := 16#6ffffffa#;
   PT_SUNWBSS      : constant Elf32_Word := 16#6ffffffa#;  --  Sun Specific segment
   PT_SUNWSTACK    : constant Elf32_Word := 16#6ffffffb#;  --  Stack segment
   PT_HISUNW       : constant Elf32_Word := 16#6fffffff#;
   PT_HIOS         : constant Elf32_Word := 16#6fffffff#;  --  End of OS-specific
   PT_LOPROC       : constant Elf32_Word := 16#70000000#;  --  Start of processor-specific
   PT_HIPROC       : constant Elf32_Word := 16#7fffffff#;  --  End of processor-specific

   --  Legal values for ELF header p_flags (segment flags).
   PF_X        : constant Elf32_Word := 1;  --  Segment is executable.
   PF_W        : constant Elf32_Word := 2;  --  Segment is writable.
   PF_R        : constant Elf32_Word := 4;  --  Segment is readable.

end ELF;

Add pragma Preelaborate

Add pragma Preelaborate


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

with ASF.Applications;
with ASF.Streams.JSON;
with Util.Streams.Texts;
with Util.Serialize.IO.JSON;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Desc   : constant ASF.Rest.Descriptor_Access := Api.Descriptors (Method);
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Desc = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
--         if not App.Has_Permission (Desc.Permission) then
--            Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
--            return;
--         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

   --  Create a route for the REST API.
   function Create_Route (Servlet  : in ASF.Servlets.Servlet_Access)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet;
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

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

with ASF.Applications;
with ASF.Streams.JSON;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Desc   : constant ASF.Rest.Descriptor_Access := Api.Descriptors (Method);
         Output : constant ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Desc = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
--         if not App.Has_Permission (Desc.Permission) then
--            Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
--            return;
--         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

   --  Create a route for the REST API.
   function Create_Route (Servlet  : in ASF.Servlets.Servlet_Access)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet;
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  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 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'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;
            Last := To_Unbounded_String (Dir);
         end if;
      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");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "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 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'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/os-none",
                     Compose_Path ("src;regtests", "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;

Add test to check iterating over the search paths in reverse order


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

with Ada.Unchecked_Deallocation;
with Util.Concurrent.Locks;
package body Util.Serialize.Contexts is

   procedure Free is new Ada.Unchecked_Deallocation (Data'Class, Data_Access);

   --  ------------------------------
   --  Context data key
   --  ------------------------------

   Lock     : Util.Concurrent.Locks.RW_Lock;
   Next_Key : Data_Key := 1;

   --  ------------------------------
   --  Allocate a unique data key for a mapper.
   --  ------------------------------
   procedure Allocate (Key : out Data_Key) is
   begin
      Lock.Write;
      Key := Next_Key;
      Next_Key := Next_Key + 1;
      Lock.Release_Write;
   end Allocate;

   function Hash (Key : in Data_Key) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Reader context
   --  ------------------------------

   --  ------------------------------
   --  Get the data object associated with the given key.
   --  Raises No_Data exception if there is no data object.
   --  ------------------------------
   function Get_Data (Ctx : in Context;
                      Key : in Data_Key) return Data_Access is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         return Data_Map.Element (Pos);
      else
         raise No_Data;
      end if;
   end Get_Data;

   --  ------------------------------
   --  Set the data object associated with the given key.
   --  ------------------------------
   procedure Set_Data (Ctx     : in out Context;
                       Key     : in Data_Key;
                       Content : in Data_Access) is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         declare
            Old : Data_Access := Data_Map.Element (Pos);
         begin
            if Old = Content then
               return;
            end if;
            Free (Old);
         end;
         Ctx.Data.Replace_Element (Position => Pos, New_Item => Content);
      else
         Ctx.Data.Insert (Key => Key, New_Item => Content);
      end if;
   end Set_Data;

   --  ------------------------------
   --  Free the context data.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Context) is
      Pos     : Data_Map.Cursor;
      Content : Data_Access;
   begin
      loop
         Pos := Ctx.Data.First;
         exit when not Data_Map.Has_Element (Pos);
         Content := Data_Map.Element (Pos);
         Free (Content);
         Ctx.Data.Delete (Pos);
      end loop;
   end Finalize;

end Util.Serialize.Contexts;

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

with Ada.Unchecked_Deallocation;
with Util.Concurrent.Counters;
package body Util.Serialize.Contexts is

   procedure Free is new Ada.Unchecked_Deallocation (Data'Class, Data_Access);

   --  ------------------------------
   --  Context data key
   --  ------------------------------
   Next_Key : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;

   --  ------------------------------
   --  Allocate a unique data key for a mapper.
   --  ------------------------------
   procedure Allocate (Key : out Data_Key) is
      Val : Integer;
   begin
      Util.Concurrent.Counters.Increment (Next_Key, Val);
      Key := Data_Key (Val);
   end Allocate;

   function Hash (Key : in Data_Key) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Reader context
   --  ------------------------------

   --  ------------------------------
   --  Get the data object associated with the given key.
   --  Raises No_Data exception if there is no data object.
   --  ------------------------------
   function Get_Data (Ctx : in Context;
                      Key : in Data_Key) return Data_Access is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         return Data_Map.Element (Pos);
      else
         raise No_Data;
      end if;
   end Get_Data;

   --  ------------------------------
   --  Set the data object associated with the given key.
   --  ------------------------------
   procedure Set_Data (Ctx     : in out Context;
                       Key     : in Data_Key;
                       Content : in Data_Access) is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         declare
            Old : Data_Access := Data_Map.Element (Pos);
         begin
            if Old = Content then
               return;
            end if;
            Free (Old);
         end;
         Ctx.Data.Replace_Element (Position => Pos, New_Item => Content);
      else
         Ctx.Data.Insert (Key => Key, New_Item => Content);
      end if;
   end Set_Data;

   --  ------------------------------
   --  Free the context data.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Context) is
      Pos     : Data_Map.Cursor;
      Content : Data_Access;
   begin
      loop
         Pos := Ctx.Data.First;
         exit when not Data_Map.Has_Element (Pos);
         Content := Data_Map.Element (Pos);
         Free (Content);
         Ctx.Data.Delete (Pos);
      end loop;
   end Finalize;

end Util.Serialize.Contexts;

Use the atomic increment and get counter operation instead of a RW lock


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

   --  ------------------------------
   --  Append the attribute name/value to the condition plugin parameter list.
   --  ------------------------------
   procedure Append (Plugin   : in out Condition_Plugin;
                     Name     : in Wiki.Strings.WString;
                     Value    : in Wiki.Strings.WString) is
   begin
      Attributes.Append (Plugin.Params, Name, Value);
   end Append;

   --  ------------------------------
   --  Evaluate the condition and return it as a boolean status.
   --  ------------------------------
   function Evaluate (Plugin   : in Condition_Plugin;
                      Params   : in Wiki.Attributes.Attribute_List) return Boolean is
      procedure Check (Name : in String;
                       Value : in Wiki.Strings.WString);

      Result : Boolean := False;
      Index  : Natural := 0;

      procedure Check (Name : in String;
                       Value : in Wiki.Strings.WString) is
         pragma Unreferenced (Name);

         Pos : Wiki.Attributes.Cursor;
      begin
         Index := Index + 1;
         if Index > 1 and not Result then
            Pos := Attributes.Find (Plugin.Params, Wiki.Strings.To_String (Value));
            Result := Attributes.Has_Element (Pos);
         end if;
      end Check;

   begin
      Attributes.Iterate (Params, Check'Access);
      return Result;
   end Evaluate;

   --  ------------------------------
   --  Get the type of condition (IF, ELSE, ELSIF, END) represented by the plugin.
   --  ------------------------------
   function Get_Condition_Kind (Plugin : in Condition_Plugin;
                                Params : in Wiki.Attributes.Attribute_List)
                                return Condition_Type is
      pragma Unreferenced (Plugin);

      Name : constant Strings.WString := Attributes.Get_Attribute (Params, "name");
   begin
      if Name = "if" then
         return CONDITION_IF;
      elsif Name = "else" then
         return CONDITION_ELSE;
      elsif Name = "elsif" then
         return CONDITION_ELSIF;
      elsif Name = "end" then
         return CONDITION_END;
      else
         return CONDITION_IF;
      end if;
   end Get_Condition_Kind;

   --  ------------------------------
   --  Evaluate the condition described by the parameters and hide or show the wiki
   --  content.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out Condition_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is
      pragma Unreferenced (Document);

      Kind : constant Condition_Type
        := Condition_Plugin'Class (Plugin).Get_Condition_Kind (Params);
   begin
      case Kind is
         when CONDITION_IF =>
            Plugin.Depth := Plugin.Depth + 1;
            Plugin.Values (Plugin.Depth) := not Condition_Plugin'Class (Plugin).Evaluate (Params);

         when CONDITION_ELSIF =>
            Plugin.Values (Plugin.Depth) := not Condition_Plugin'Class (Plugin).Evaluate (Params);

         when CONDITION_ELSE =>
            Plugin.Values (Plugin.Depth) := not Plugin.Values (Plugin.Depth);

         when CONDITION_END =>
            Plugin.Depth := Plugin.Depth - 1;

      end case;
      Context.Previous.Is_Hidden := Plugin.Values (Plugin.Depth);
   end Expand;

end Wiki.Plugins.Conditions;

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

   --  ------------------------------
   --  Append the attribute name/value to the condition plugin parameter list.
   --  ------------------------------
   procedure Append (Plugin   : in out Condition_Plugin;
                     Name     : in Wiki.Strings.WString;
                     Value    : in Wiki.Strings.WString) is
   begin
      Attributes.Append (Plugin.Params, Name, Value);
   end Append;

   --  ------------------------------
   --  Evaluate the condition and return it as a boolean status.
   --  ------------------------------
   function Evaluate (Plugin   : in Condition_Plugin;
                      Params   : in Wiki.Attributes.Attribute_List) return Boolean is
      procedure Check (Name : in String;
                       Value : in Wiki.Strings.WString);

      Result : Boolean := False;
      Index  : Natural := 0;

      procedure Check (Name : in String;
                       Value : in Wiki.Strings.WString) is
         pragma Unreferenced (Name);

         Pos : Wiki.Attributes.Cursor;
      begin
         Index := Index + 1;
         if Index > 1 and not Result then
            Pos := Attributes.Find (Plugin.Params, Wiki.Strings.To_String (Value));
            Result := Attributes.Has_Element (Pos);
         end if;
      end Check;

   begin
      Attributes.Iterate (Params, Check'Access);
      return Result;
   end Evaluate;

   --  ------------------------------
   --  Get the type of condition (IF, ELSE, ELSIF, END) represented by the plugin.
   --  ------------------------------
   function Get_Condition_Kind (Plugin : in Condition_Plugin;
                                Params : in Wiki.Attributes.Attribute_List)
                                return Condition_Type is
      pragma Unreferenced (Plugin);

      Name : constant Strings.WString := Attributes.Get_Attribute (Params, "name");
   begin
      if Name = "if" then
         return CONDITION_IF;
      elsif Name = "else" then
         return CONDITION_ELSE;
      elsif Name = "elsif" then
         return CONDITION_ELSIF;
      elsif Name = "end" then
         return CONDITION_END;
      else
         return CONDITION_IF;
      end if;
   end Get_Condition_Kind;

   --  ------------------------------
   --  Evaluate the condition described by the parameters and hide or show the wiki
   --  content.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out Condition_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in out Plugin_Context) is
      pragma Unreferenced (Document);

      Kind : constant Condition_Type
        := Condition_Plugin'Class (Plugin).Get_Condition_Kind (Params);
   begin
      case Kind is
         when CONDITION_IF =>
            Plugin.Depth := Plugin.Depth + 1;
            Plugin.Values (Plugin.Depth) := not Condition_Plugin'Class (Plugin).Evaluate (Params);

         when CONDITION_ELSIF =>
            Plugin.Values (Plugin.Depth) := not Condition_Plugin'Class (Plugin).Evaluate (Params);

         when CONDITION_ELSE =>
            Plugin.Values (Plugin.Depth) := not Plugin.Values (Plugin.Depth);

         when CONDITION_END =>
            Plugin.Depth := Plugin.Depth - 1;

      end case;
      Context.Previous.Is_Hidden := Plugin.Values (Plugin.Depth);
   end Expand;

end Wiki.Plugins.Conditions;

Change the Context parameter to 'in out' because we may need to access the filters


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

with Ada.Containers.Vectors;
with Util.Strings.Sets;
with Util.Strings.Vectors;
package Gen.Commands.Templates is

   --  ------------------------------
   --  Template Generic Command
   --  ------------------------------
   --  This command adds a XHTML page to the web application.
   type Command is new Gen.Commands.Command with private;
   type Command_Access is access all Command'Class;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

   --  Read the template commands defined in dynamo configuration directory.
   procedure Read_Commands (Generator : in out Gen.Generator.Handler);

private

   type Param is record
      Name        : Ada.Strings.Unbounded.Unbounded_String;
      Argument    : Ada.Strings.Unbounded.Unbounded_String;
      Value       : Ada.Strings.Unbounded.Unbounded_String;
      Is_Optional : Boolean := False;
   end record;

   package Param_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Param);

   type Patch is record
      Template  : Ada.Strings.Unbounded.Unbounded_String;
      After     : Util.Strings.Vectors.Vector;
      Missing   : Util.Strings.Vectors.Vector;
      Before    : Ada.Strings.Unbounded.Unbounded_String;
      Title     : Ada.Strings.Unbounded.Unbounded_String;
      Optional  : Boolean := False;
   end record;

   package Patch_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Patch);

   type Command is new Gen.Commands.Command with record
      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Title     : Ada.Strings.Unbounded.Unbounded_String;
      Usage     : Ada.Strings.Unbounded.Unbounded_String;
      Help_Msg  : Ada.Strings.Unbounded.Unbounded_String;
      Base_Dir  : Ada.Strings.Unbounded.Unbounded_String;
      Templates : Util.Strings.Sets.Set;
      Patches   : Patch_Vectors.Vector;
      Params    : Param_Vectors.Vector;
   end record;

end Gen.Commands.Templates;

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

with Ada.Containers.Vectors;
with Util.Strings.Sets;
with Util.Strings.Vectors;
package Gen.Commands.Templates is

   --  ------------------------------
   --  Template Generic Command
   --  ------------------------------
   --  This command adds a XHTML page to the web application.
   type Command is new Gen.Commands.Command with private;
   type Command_Access is access all Command'Class;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler);

   --  Read the template commands defined in dynamo configuration directory.
   procedure Read_Commands (Generator : in out Gen.Generator.Handler);

private

   type Param is record
      Name        : Ada.Strings.Unbounded.Unbounded_String;
      Argument    : Ada.Strings.Unbounded.Unbounded_String;
      Value       : Ada.Strings.Unbounded.Unbounded_String;
      Is_Optional : Boolean := False;
   end record;

   package Param_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Param);

   type Patch is record
      Template  : Ada.Strings.Unbounded.Unbounded_String;
      After     : Util.Strings.Vectors.Vector;
      Missing   : Util.Strings.Vectors.Vector;
      Before    : Ada.Strings.Unbounded.Unbounded_String;
      Title     : Ada.Strings.Unbounded.Unbounded_String;
      Optional  : Boolean := False;
   end record;

   package Patch_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Patch);

   type Command is new Gen.Commands.Command with record
      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Title     : Ada.Strings.Unbounded.Unbounded_String;
      Usage     : Ada.Strings.Unbounded.Unbounded_String;
      Help_Msg  : Ada.Strings.Unbounded.Unbounded_String;
      Base_Dir  : Ada.Strings.Unbounded.Unbounded_String;
      Templates : Util.Strings.Sets.Set;
      Patches   : Patch_Vectors.Vector;
      Params    : Param_Vectors.Vector;
   end record;

end Gen.Commands.Templates;

Update to use an in out parameter for Help procedure


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

   Not_Found : exception;

   type Frame_Type is private;
   type Frame_Table is array (Natural range <>) of MAT.Types.Target_Addr;

--     subtype Frame_Table is MAT.Events.Frame_Table;

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

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

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

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

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

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

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

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

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

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

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

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

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

   --  Check whether the inner most frame contains a call to the function described by
   --  the address range.  This function looks only at the inner most frame and not the
   --  whole stack frame.
   function By_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean;

private

   Frame_Group_Size : constant Natural := 4;

   subtype Local_Depth_Type is Natural range 0 .. Frame_Group_Size;

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

   type Frame;
   type Frame_Type is access all Frame;

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

end MAT.Frames;

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

   Not_Found : exception;

   type Frame_Type is private;
   type Frame_Table is array (Natural range <>) of MAT.Types.Target_Addr;

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

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

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

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

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

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

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

   --  Check whether the inner most frame contains a call to the function described by
   --  the address range.  This function looks only at the inner most frame and not the
   --  whole stack frame.
   function By_Function (Frame : in Frame_Type;
                         From  : in MAT.Types.Target_Addr;
                         To    : in MAT.Types.Target_Addr) return Boolean;
   procedure Verify_Frames;

private

   type Frame;
   type Frame_Type is access all Frame;

   --  The frame information is readonly and we can safely use the By_Function, In_Function
   --  and Backtrace without protection.  Insertion and creation of stack frame must be
   --  protected through a protected type managed by Target_Frames.  All the frame instances
   --  are released when the Target_Frames protected type is released.
   type Frame (Parent : Frame_Type;
               Depth  : Natural;
               Pc     : MAT.Types.Target_Addr) is limited record
      Next     : Frame_Type := null;
      Children : Frame_Type := null;
      Used     : Natural   := 0;
   end record;

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

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

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

end MAT.Frames;

Refactor and simplify the stack frame management and representation - Make the Create_Root, Insert, Destroy private operations - Change the Frame record to a limited record with readonly members and keep only one PC address per Frame record instance