-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 2011- 2021 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;

with Ada.IO_Exceptions;
with Ada.Directories;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
with ADO.Configs;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Connections;
   use Interfaces;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Base_Time : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year  => 1970,
                                                                   Month => 1,
                                                                   Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Unsigned_32 := 60;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Last_Query  : Query_Index := 0;
   Last_File   : File_Index := 0;

   --  Convert a Time to an Unsigned_32.
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32;
   pragma Inline_Always (To_Unsigned_32);

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (File : in Query_File_Info) return Unsigned_32;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Last_Query   := Last_Query + 1;
      Query.File   := File;
      Query.Next   := File.Queries;
      Query.Query  := Last_Query;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         Last_File := Last_File + 1;
         File.Next := Query_Files;
         File.File := Last_File;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant Connections.Driver_Access
           := Connections.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Convert a Time to an Unsigned_32.
   --  ------------------------------
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32 is
      D : constant Duration := Duration '(T - Base_Time);
   begin
      return Unsigned_32 (D);
   end To_Unsigned_32;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (File : in Query_File_Info) return Unsigned_32 is
      Path : constant String := To_String (File.Path);
   begin
      return To_Unsigned_32 (Ada.Directories.Modification_Time (Path));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Path);
         return 0;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (File : in out Query_File_Info) return Boolean is
      Now : constant Unsigned_32 := To_Unsigned_32 (Ada.Calendar.Clock);
   begin
      --  Have we passed the next check time?
      if File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Unsigned_32 := Modification_Time (File);
      begin
         if File.Last_Modified = M then
            return False;
         end if;
         File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Manager : in Query_Manager;
                         File    : in out Query_File_Info) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT, FIELD_QUERY);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is record
         --  File       : Query_File_Access;
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Ref.Ref;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (File, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            if Into.Query_Def /= null then
               Into.Query := Query_Info_Ref.Create;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Main_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Count_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_QUERY =>
            if Into.Query_Def /= null then
               --  Now we can safely setup the query info associated with the query definition.
               Manager.Queries (Into.Query_Def.Query) := Into.Query;
            end if;
            Into.Query_Def := null;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
      Mapper     : Util.Serialize.Mappers.Processing;
      Path       : constant String := To_String (File.Path);
   begin
      Log.Info ("Reading XML query {0}", Path);
      --  Loader.File   := Into;
      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Sql_Mapper.Add_Mapping ("query/sql-count/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query", FIELD_QUERY);
      Mapper.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Mapper, Loader'Access);

      --  Read the XML query file.
      if Ada.Directories.Exists (Path) then
         Reader.Parse (Path, Mapper);
         File.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;
         return;
      end if;

      if Manager.Loader = null then
         Log.Error ("XML query file '{0}' does not exist", Path);

         File.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;
         return;
      end if;

      Log.Info ("Loading query {0} from static loader", File.File.Name.all);

      declare
         Content : constant access constant String
           := Manager.Loader (File.File.Name.all);
      begin
         if Content /= null then
            Reader.Parse_String (Content.all, Mapper);
         else
            Log.Error ("XML query file '{0}' does not exist", Path);
         end if;
         File.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;
      end;
   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Manager : in Query_Manager;
                         Into    : in Query_Definition_Access) is
   begin
      if Manager.Queries (Into.Query).Is_Null
        or else Is_Modified (Manager.Files (Into.File.File))
      then
         Read_Query (Manager, Manager.Files (Into.File.File));
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Manager : in out Query_Manager;
                         Config  : in ADO.Connections.Configuration'Class) is
      function Get_Config (Name : in String) return String;

      function Get_Config (Name : in String) return String is
         Value : constant String := Config.Get_Property (Name);
      begin
         if Value'Length > 0 then
            return Value;
         else
            return ADO.Configs.Get_Config (Name);
         end if;
      end Get_Config;

      Paths : constant String := Get_Config (Configs.QUERY_PATHS_CONFIG);
      Load  : constant Boolean := Get_Config (Configs.QUERY_LOAD_CONFIG) = "true";
      File  : Query_File_Access := Query_Files;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      if Manager.Queries = null then
         Manager.Queries := new Query_Table (1 .. Last_Query);
      end if;
      if Manager.Files = null then
         Manager.Files := new File_Table (1 .. Last_File);
      end if;
      Manager.Driver := Config.Get_Driver;
      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Name.all,
                                                                 Paths => Paths);
         begin
            Manager.Files (File.File).File := File;
            Manager.Files (File.File).Last_Modified := 0;
            Manager.Files (File.File).Next_Check := 0;
            Manager.Files (File.File).Path := To_Unbounded_String (Path);

            if Load then
               Read_Query (Manager, Manager.Files (File.File));
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body File is
   begin
      File.Name := Name'Access;
      File.Sha1_Map := Hash'Access;
   end File;

   package body Query is
   begin
      Query.Name := Query_Name'Access;
      Query.File := File;
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 2011- 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 Ada.IO_Exceptions;
with Ada.Directories;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
with ADO.Configs;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Connections;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Init_Time : constant Ada.Calendar.Time
     := Ada.Calendar.Time_Of (Year  => Ada.Calendar.Year_Number'First,
                              Month => 1,
                              Day   => 1);

   Infinity_Time : constant Ada.Calendar.Time
     := Ada.Calendar.Time_Of (Year  => Ada.Calendar.Year_Number'Last,
                              Month => 1,
                              Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Duration := 60.0;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Last_Query  : Query_Index := 0;
   Last_File   : File_Index := 0;

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (File : in Query_File_Info) return Ada.Calendar.Time;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Last_Query   := Last_Query + 1;
      Query.File   := File;
      Query.Next   := File.Queries;
      Query.Query  := Last_Query;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         Last_File := Last_File + 1;
         File.Next := Query_Files;
         File.File := Last_File;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant Connections.Driver_Access
           := Connections.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (File : in Query_File_Info) return Ada.Calendar.Time is
      Path : constant String := To_String (File.Path);
   begin
      return Ada.Directories.Modification_Time (Path);

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Path);
         return Init_Time;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (File : in out Query_File_Info) return Boolean is
      Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      --  Have we passed the next check time?
      if File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Ada.Calendar.Time := Modification_Time (File);
      begin
         if File.Last_Modified = M then
            return False;
         end if;
         File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Manager : in Query_Manager;
                         File    : in out Query_File_Info) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT, FIELD_QUERY);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is limited record
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Ref.Ref;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (File, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            if Into.Query_Def /= null then
               Into.Query := Query_Info_Ref.Create;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Main_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Count_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_QUERY =>
            if Into.Query_Def /= null then
               --  Now we can safely setup the query info associated with the query definition.
               Manager.Queries (Into.Query_Def.Query) := Into.Query;
            end if;
            Into.Query_Def := null;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
      Mapper     : Util.Serialize.Mappers.Processing;
      Path       : constant String := To_String (File.Path);
   begin
      Log.Info ("Reading XML query {0}", Path);

      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Sql_Mapper.Add_Mapping ("query/sql-count/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query", FIELD_QUERY);
      Mapper.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Mapper, Loader'Access);

      --  Read the XML query file.
      if Ada.Directories.Exists (Path) then
         Reader.Parse (Path, Mapper);
         File.Next_Check := Ada.Calendar.Clock + FILE_CHECK_DELTA_TIME;
         return;
      end if;

      if Manager.Loader = null then
         Log.Error ("XML query file '{0}' does not exist", Path);

         File.Next_Check := Ada.Calendar.Clock + FILE_CHECK_DELTA_TIME;
         return;
      end if;

      Log.Info ("Loading query {0} from static loader", File.File.Name.all);

      declare
         Content : constant access constant String
           := Manager.Loader (File.File.Name.all);
      begin
         if Content /= null then
            Reader.Parse_String (Content.all, Mapper);
            File.Next_Check := Infinity_Time;
         else
            Log.Error ("XML query file '{0}' does not exist", Path);
            File.Next_Check := Ada.Calendar.Clock + FILE_CHECK_DELTA_TIME;
         end if;
      end;
   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Manager : in Query_Manager;
                         Into    : in Query_Definition_Access) is
   begin
      if Manager.Queries (Into.Query).Is_Null
        or else Is_Modified (Manager.Files (Into.File.File))
      then
         Read_Query (Manager, Manager.Files (Into.File.File));
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Manager : in out Query_Manager;
                         Config  : in ADO.Connections.Configuration'Class) is
      function Get_Config (Name : in String) return String;

      function Get_Config (Name : in String) return String is
         Value : constant String := Config.Get_Property (Name);
      begin
         if Value'Length > 0 then
            return Value;
         else
            return ADO.Configs.Get_Config (Name);
         end if;
      end Get_Config;

      Paths : constant String := Get_Config (Configs.QUERY_PATHS_CONFIG);
      Load  : constant Boolean := Get_Config (Configs.QUERY_LOAD_CONFIG) = "true";
      File  : Query_File_Access := Query_Files;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      if Manager.Queries = null then
         Manager.Queries := new Query_Table (1 .. Last_Query);
      end if;
      if Manager.Files = null then
         Manager.Files := new File_Table (1 .. Last_File);
      end if;
      Manager.Driver := Config.Get_Driver;
      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Name.all,
                                                                 Paths => Paths);
         begin
            Manager.Files (File.File).File := File;
            Manager.Files (File.File).Last_Modified := Init_Time;
            Manager.Files (File.File).Next_Check := Init_Time;
            Manager.Files (File.File).Path := To_Unbounded_String (Path);

            if Load then
               Read_Query (Manager, Manager.Files (File.File));
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body File is
   begin
      File.Name := Name'Access;
      File.Sha1_Map := Hash'Access;
   end File;

   package body Query is
   begin
      Query.Name := Query_Name'Access;
      Query.File := File;
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

Fix #10: if the XML query is loaded from a static loader, don't check the modification time and set the Next_Check date to the infinity


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

with Util.Tests;
package Util.Encoders.Tests is

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

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

   procedure Test_Hex (T : in out Test);
   procedure Test_Base64_Encode (T : in out Test);
   procedure Test_Base64_Decode (T : in out Test);
   procedure Test_Base64_URL_Encode (T : in out Test);
   procedure Test_Base64_URL_Decode (T : in out Test);
   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder);
   procedure Test_Base64_Benchmark (T : in out Test);
   procedure Test_SHA1_Encode (T : in out Test);

   --  Benchmark test for SHA1
   procedure Test_SHA1_Benchmark (T : in out Test);

   --  Test HMAC-SHA1
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test);

   --  Test encoding leb128.
   procedure Test_LEB128 (T : in out Test);

   --  Test encoding leb128 + base64url.
   procedure Test_Base64_LEB128 (T : in out Test);

end Util.Encoders.Tests;

-----------------------------------------------------------------------
--  util-encodes-tests - Test for encoding
--  Copyright (C) 2009, 2010, 2011, 2012, 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 Util.Tests;
package Util.Encoders.Tests is

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

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

   procedure Test_Hex (T : in out Test);
   procedure Test_Base64_Encode (T : in out Test);
   procedure Test_Base64_Decode (T : in out Test);
   procedure Test_Base64_URL_Encode (T : in out Test);
   procedure Test_Base64_URL_Decode (T : in out Test);
   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder);
   procedure Test_Base64_Benchmark (T : in out Test);
   procedure Test_SHA1_Encode (T : in out Test);
   procedure Test_SHA256_Encode (T : in out Test);

   --  Benchmark test for SHA1
   procedure Test_SHA1_Benchmark (T : in out Test);

   --  Test HMAC-SHA1
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test);

   --  Test encoding leb128.
   procedure Test_LEB128 (T : in out Test);

   --  Test encoding leb128 + base64url.
   procedure Test_Base64_LEB128 (T : in out Test);

end Util.Encoders.Tests;

Declare the Test_SHA256_Encode procedure


-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 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 GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      Doc  : Gen.Artifacts.Docs.Artifact;
      M    : Gen.Model.Packages.Model_Definition;
      Arg1 : constant String := Get_Argument;
      Arg2 : constant String := Get_Argument;
      Fmt  : Gen.Artifacts.Docs.Doc_Format := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      if Arg1'Length = 0 then
         Generator.Error ("Missing target directory");
         return;
      elsif Arg1 (Arg1'First) /= '-' then
         if Arg2'Length /= 0 then
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         --  Setup the target directory where the distribution is created.
         Generator.Set_Result_Directory (Arg1);
      else
         if Arg1 = "-markdown" then
            Fmt := Gen.Artifacts.Docs.DOC_MARKDOWN;
         elsif Arg1 = "-google" then
            Fmt := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
         else
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         if Arg2'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Arg2);
      end if;
      Doc.Set_Format (Fmt);
      Doc.Prepare (M, Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc [-markdown|-google] target-dir");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 2012, 2015, 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 GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

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

      Doc  : Gen.Artifacts.Docs.Artifact;
      M    : Gen.Model.Packages.Model_Definition;
      Arg1 : constant String := Get_Argument;
      Arg2 : constant String := Get_Argument;
      Fmt  : Gen.Artifacts.Docs.Doc_Format := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      if Arg1'Length = 0 then
         Generator.Error ("Missing target directory");
         return;
      elsif Arg1 (Arg1'First) /= '-' then
         if Arg2'Length /= 0 then
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         --  Setup the target directory where the distribution is created.
         Generator.Set_Result_Directory (Arg1);
      else
         if Arg1 = "-markdown" then
            Fmt := Gen.Artifacts.Docs.DOC_MARKDOWN;
         elsif Arg1 = "-google" then
            Fmt := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
         else
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         if Arg2'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Arg2);
      end if;
      Doc.Set_Format (Fmt);
      Doc.Prepare (M, Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc [-markdown|-google] target-dir");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

Update to use the new command implementation


-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  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.
-----------------------------------------------------------------------
package body MAT.Events.Tools is

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   --  ------------------------------
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector) is

      function "<" (Left, Right : in Frame_Info_Type) return Boolean;

      function "<" (Left, Right : in Frame_Info_Type) return Boolean is
      begin
         if Left.Key.Level < Right.Key.Level then
            return True;
         else
            return False;
         end if;
      end "<";

      package Sort_Frame_Info is new Frame_Info_Vectors.Generic_Sorting;

      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Frame_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item.Key  := Frame_Event_Info_Maps.Key (Iter);
         Item.Info := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Frame_Info.Sort (List);
   end Build_Frame_Info;

end MAT.Events.Tools;

-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  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.
-----------------------------------------------------------------------
package body MAT.Events.Tools is

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Collect statistics information about events.
   --  ------------------------------
   procedure Collect_Info (Into  : in out Event_Info_Type;
                           Event : in MAT.Events.Target_Event_Type) is
   begin
      Into.Last_Event := Event;
      if Event.Event = 2 then
         Into.Malloc_Count := Into.Malloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;

      elsif Event.Event = 3 then
         Into.Realloc_Count := Into.Realloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;
         Into.Free_Size := Into.Free_Size + Event.Old_Size;

      elsif Event.Event = 4 then
         Into.Free_Count := Into.Free_Count + 1;
         Into.Free_Size := Into.Free_Size + Event.Size;
      end if;
   end Collect_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   --  ------------------------------
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector) is

      function "<" (Left, Right : in Frame_Info_Type) return Boolean;

      function "<" (Left, Right : in Frame_Info_Type) return Boolean is
      begin
         if Left.Key.Level < Right.Key.Level then
            return True;
         else
            return False;
         end if;
      end "<";

      package Sort_Frame_Info is new Frame_Info_Vectors.Generic_Sorting;

      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Frame_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item.Key  := Frame_Event_Info_Maps.Key (Iter);
         Item.Info := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Frame_Info.Sort (List);
   end Build_Frame_Info;

end MAT.Events.Tools;

Implement the Collect_Info procedure

Implement the Collect_Info procedure


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

package body MAT.Consoles.Text is

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is
   begin
      Ada.Text_IO.Put (Value);
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
   begin
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end MAT.Consoles.Text;

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

package body MAT.Consoles.Text is

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is
   begin
      Ada.Text_IO.Put (Value);
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
   begin
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      null;
   end Start_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end MAT.Consoles.Text;

Implement the Start_Title operation

Implement the Start_Title operation


with Keccak.Generic_Parallel_Permutation_Parallel_Fallback;
with Keccak.Generic_Parallel_Permutation_Serial_Fallback;
with Keccak.Keccak_1600;
with Keccak.Keccak_1600.Rounds_24;
with Keccak.Keccak_1600.Rounds_12;
with Keccak.Types;
with Interfaces;

pragma Elaborate_All (Keccak.Generic_Parallel_Permutation_Parallel_Fallback);
pragma Elaborate_All (Keccak.Generic_Parallel_Permutation_Serial_Fallback);

--  @brief@
--  Defines procedures for running Keccak-f permutations in parallel for
--  2x, 4x, and 8x parallelism, as well as serial permutations.
--
--  @description@
--
--  This package must define the following types and procedures:
--    * Permute_S1_R12 - Serial Keccak-p[1600] permutation with 12 rounds.
--    * Permute_S1_R24 - Serial Keccak-p[1600] permutation with 24 rounds.
--
--  For 2x parallelism:
--    * Parallel_State_P2
--    * Init_P2
--    * Permute_All_P2_R12
--    * Permute_All_P2_R24
--    * XOR_Bits_Into_State_Separate_P2
--    * Extract_Bytes_P2
--
--  For 4x parallelism:
--    * Parallel_State_P4
--    * Init_P4
--    * Permute_All_P4_R12
--    * Permute_All_P4_R24
--    * XOR_Bits_Into_State_Separate_P4
--    * Extract_Bytes_P4
--
--  For 8x parallelism:
--    * Parallel_State_P8
--    * Init_P8
--    * Permute_All_P8_R12
--    * Permute_All_P8_R24
--    * XOR_Bits_Into_State_Separate_P8
--    * Extract_Bytes_P8
--
--  Any other declarations in this package are architecture-specific and should
--  not be relied upon.
package Keccak.Parallel_Keccak_1600
with SPARK_Mode => On
is

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x2

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P2
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 2);

   subtype Parallel_State_P2 is KeccakF_1600_P2.Parallel_State;

   procedure Init_P2 (S : out KeccakF_1600_P2.Parallel_State)
                      renames KeccakF_1600_P2.Init;

   procedure XOR_Bits_Into_State_Separate_P2
     (S           : in out Parallel_State_P2;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P2.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P2
     (S           : in out Parallel_State_P2;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P2.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P2
     (S           : in     Parallel_State_P2;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P2.Extract_Bytes;

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x4

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P4
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 4);

   subtype Parallel_State_P4 is KeccakF_1600_P4.Parallel_State;

   procedure Init_P4 (S : out KeccakF_1600_P4.Parallel_State)
                      renames KeccakF_1600_P4.Init;

   procedure XOR_Bits_Into_State_Separate_P4
     (S           : in out Parallel_State_P4;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P4.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P4
     (S           : in out Parallel_State_P4;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P4.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P4
     (S           : in     Parallel_State_P4;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P4.Extract_Bytes;

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x8

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P8
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 8);

   subtype Parallel_State_P8 is KeccakF_1600_P8.Parallel_State;

   procedure Init_P8 (S : out KeccakF_1600_P8.Parallel_State)
                      renames KeccakF_1600_P8.Init;

   procedure XOR_Bits_Into_State_Separate_P8
     (S           : in out Parallel_State_P8;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P8.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P8
     (S           : in out Parallel_State_P8;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P8.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P8
     (S           : in     Parallel_State_P8;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P8.Extract_Bytes;

end Keccak.Parallel_Keccak_1600;

with Keccak.Generic_Parallel_Permutation_Parallel_Fallback;
with Keccak.Generic_Parallel_Permutation_Serial_Fallback;
with Keccak.Keccak_1600;
with Keccak.Keccak_1600.Rounds_24;
with Keccak.Keccak_1600.Rounds_12;
with Keccak.Types;
with Interfaces;

pragma Elaborate_All (Keccak.Generic_Parallel_Permutation_Parallel_Fallback);
pragma Elaborate_All (Keccak.Generic_Parallel_Permutation_Serial_Fallback);

--  @brief@
--  Defines procedures for running Keccak-f permutations in parallel for
--  2x, 4x, and 8x parallelism, as well as serial permutations.
--
--  @description@
--
--  This package must define the following types and procedures:
--    * Permute_S1_R12 - Serial Keccak-p[1600] permutation with 12 rounds.
--    * Permute_S1_R24 - Serial Keccak-p[1600] permutation with 24 rounds.
--
--  For 2x parallelism:
--    * Parallel_State_P2
--    * Init_P2
--    * Permute_All_P2_R12
--    * Permute_All_P2_R24
--    * XOR_Bits_Into_State_Separate_P2
--    * Extract_Bytes_P2
--
--  For 4x parallelism:
--    * Parallel_State_P4
--    * Init_P4
--    * Permute_All_P4_R12
--    * Permute_All_P4_R24
--    * XOR_Bits_Into_State_Separate_P4
--    * Extract_Bytes_P4
--
--  For 8x parallelism:
--    * Parallel_State_P8
--    * Init_P8
--    * Permute_All_P8_R12
--    * Permute_All_P8_R24
--    * XOR_Bits_Into_State_Separate_P8
--    * Extract_Bytes_P8
--
--  Any other declarations in this package are architecture-specific and should
--  not be relied upon.
package Keccak.Parallel_Keccak_1600
with SPARK_Mode => On
is

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x2

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P2
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.Lane_Complemented_State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 2);

   subtype Parallel_State_P2 is KeccakF_1600_P2.Parallel_State;

   procedure Init_P2 (S : out KeccakF_1600_P2.Parallel_State)
                      renames KeccakF_1600_P2.Init;

   procedure XOR_Bits_Into_State_Separate_P2
     (S           : in out Parallel_State_P2;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P2.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P2
     (S           : in out Parallel_State_P2;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P2.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P2
     (S           : in     Parallel_State_P2;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P2.Extract_Bytes;

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x4

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P4
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.Lane_Complemented_State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 4);

   subtype Parallel_State_P4 is KeccakF_1600_P4.Parallel_State;

   procedure Init_P4 (S : out KeccakF_1600_P4.Parallel_State)
                      renames KeccakF_1600_P4.Init;

   procedure XOR_Bits_Into_State_Separate_P4
     (S           : in out Parallel_State_P4;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P4.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P4
     (S           : in out Parallel_State_P4;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P4.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P4
     (S           : in     Parallel_State_P4;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P4.Extract_Bytes;

   ----------------------------------------------------------------------------
   -- Keccak-f[1600]x8

   --  No SIMD available on this architecture. Fall back to serial implementation.

   package KeccakF_1600_P8
   is new Keccak.Generic_Parallel_Permutation_Serial_Fallback
     (Permutation_State   => Keccak_1600.KeccakF_1600.Lane_Complemented_State,
      Init                => Keccak_1600.KeccakF_1600.Init,
      XOR_Bits_Into_State => Keccak_1600.KeccakF_1600_Lanes.XOR_Bits_Into_State,
      Extract_Bytes       => Keccak_1600.KeccakF_1600_Lanes.Extract_Bytes,
      State_Size          => 1600,
      Parallelism         => 8);

   subtype Parallel_State_P8 is KeccakF_1600_P8.Parallel_State;

   procedure Init_P8 (S : out KeccakF_1600_P8.Parallel_State)
                      renames KeccakF_1600_P8.Init;

   procedure XOR_Bits_Into_State_Separate_P8
     (S           : in out Parallel_State_P8;
      Data        : in     Types.Byte_Array;
      Data_Offset : in     Natural;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P8.XOR_Bits_Into_State_Separate;

   procedure XOR_Bits_Into_State_All_P8
     (S           : in out Parallel_State_P8;
      Data        : in     Types.Byte_Array;
      Bit_Len     : in     Natural)
      renames KeccakF_1600_P8.XOR_Bits_Into_State_All;

   procedure Extract_Bytes_P8
     (S           : in     Parallel_State_P8;
      Data        : in out Types.Byte_Array;
      Data_Offset : in     Natural;
      Byte_Len    : in     Natural)
      renames KeccakF_1600_P8.Extract_Bytes;

end Keccak.Parallel_Keccak_1600;

Fix a build error for ARCH=generic

Fix a build error for ARCH=generic


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 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.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 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.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

Implement the new function Get_Policy_Index


------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Calendar;
with Ada.Command_Line;
with Ada.Text_IO;
with Natools.Time_IO.RFC_3339;
with Natools.Time_Keys;

procedure Timekey is
   procedure Process (Line : in String);
      --  Guess the type of Line and convert it to or from type.

   procedure Process_Input;
      --  Read lines from current input and process them.

   Input_Processed : Boolean := False;
   Empty : Boolean := True;
   Verbose : Boolean := False;

   procedure Process (Line : in String) is
   begin
      if Verbose then
         Ada.Text_IO.Put (Line);
      end if;

      if Natools.Time_Keys.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_IO.RFC_3339.Image
              (Natools.Time_Keys.To_Time (Line), Duration'Aft, False));

      elsif Natools.Time_IO.RFC_3339.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_Keys.To_Key (Natools.Time_IO.RFC_3339.Value (Line)));
      end if;
   end Process;

   procedure Process_Input is
   begin
      if Input_Processed then
         return;
      else
         Input_Processed := True;
      end if;

      begin
         loop
            Process (Ada.Text_IO.Get_Line);
         end loop;
      exception
         when Ada.Text_IO.End_Error => null;
      end;
   end Process_Input;
begin
   for I in 1 .. Ada.Command_Line.Argument_Count loop
      if Ada.Command_Line.Argument (I) = "-" then
         Empty := False;
         Process_Input;
      elsif Ada.Command_Line.Argument (I) = "-v" then
         Verbose := True;
      else
         Empty := False;
         Process (Ada.Command_Line.Argument (I));
      end if;
   end loop;

   if Empty then
      declare
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         if Verbose then
            Ada.Text_IO.Put
              (Natools.Time_IO.RFC_3339.Image (Now, Duration'Aft, False)
               & " => ");
         end if;

         Ada.Text_IO.Put_Line (Natools.Time_Keys.To_Key (Now));
      end;
   end if;
end Timekey;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Calendar;
with Ada.Command_Line;
with Ada.Text_IO;
with Natools.Time_IO.RFC_3339;
with Natools.Time_Keys;

procedure Timekey is
   procedure Process (Line : in String);
      --  Guess the type of Line and convert it to or from type.

   procedure Process_Input;
      --  Read lines from current input and process them.

   Input_Processed : Boolean := False;
   Empty : Boolean := True;
   Verbose : Boolean := False;

   procedure Process (Line : in String) is
   begin
      if Verbose then
         Ada.Text_IO.Put (Line);
      end if;

      if Natools.Time_Keys.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_IO.RFC_3339.Image
              (Natools.Time_Keys.To_Time (Line), Duration'Aft, False));

      elsif Natools.Time_IO.RFC_3339.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_Keys.To_Key (Natools.Time_IO.RFC_3339.Value (Line)));
      end if;
   end Process;

   procedure Process_Input is
   begin
      if Input_Processed then
         return;
      else
         Input_Processed := True;
      end if;

      begin
         loop
            Process (Ada.Text_IO.Get_Line);
         end loop;
      exception
         when Ada.Text_IO.End_Error => null;
      end;
   end Process_Input;
begin
   for I in 1 .. Ada.Command_Line.Argument_Count loop
      declare
         Arg : constant String := Ada.Command_Line.Argument (I);
      begin
         if Arg = "-" then
            Empty := False;
            Process_Input;
         elsif Arg = "-v" then
            Verbose := True;
         else
            Empty := False;
            Process (Arg);
         end if;
      end;
   end loop;

   if Empty then
      declare
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         if Verbose then
            Ada.Text_IO.Put
              (Natools.Time_IO.RFC_3339.Image (Now, Duration'Aft, False)
               & " => ");
         end if;

         Ada.Text_IO.Put_Line (Natools.Time_Keys.To_Key (Now));
      end;
   end if;
end Timekey;

tools/timekey: refactor command-line argument processing


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

with AUnit.Test_Suites;
with AUnit.Test_Fixtures;

package Util.Serialize.IO.XML.Tests is

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite);

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

   procedure Test_Parser (T : in out Test);

   procedure Test_Writer (T : in out Test);

end Util.Serialize.IO.XML.Tests;

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

with AUnit.Test_Suites;
with AUnit.Test_Fixtures;

package Util.Serialize.IO.XML.Tests is

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite);

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

   --  Test XML de-serialization
   procedure Test_Parser (T : in out Test);

   --  Test XML serialization
   procedure Test_Writer (T : in out Test);

end Util.Serialize.IO.XML.Tests;

Add comment

Add comment


-----------------------------------------------------------------------
--  objects.cache -- Object cache
--  Copyright (C) 2009, 2010 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.Finalization;

with ADO.Objects;
with Ada.Containers.Indefinite_Hashed_Sets;

--  The ADO.Objects.Cache holds a cache of object records.
--  The cache maintains a set of objects that were loaded for a given session.
--
--  The cache is not thread-safe.  It is not intended to be shared directly.
package ADO.Objects.Cache is

   type Object_Cache is limited private;

   --  Insert the object in the cache.
   --  The reference counter associated with the object is incremented.
   procedure Insert (Cache  : in out Object_Cache;
                     Object : in Object_Record_Access);

   --  Insert the object in the cache
   --  The reference counter associated with the object is incremented.
   procedure Insert (Cache  : in out Object_Cache;
                     Object : in Object_Ref'Class);

   --  Check if the object is contained in the cache
   function Contains (Cache : in Object_Cache;
                      Key   : in Object_Key) return Boolean;

   function Find (Cache : in Object_Cache;
                  Key   : in Object_Key) return Object_Record_Access;

   procedure Find (Cache  : in Object_Cache;
                   Object : in out Object_Ref'Class;
                   Key    : in Object_Key);

   --  Remove the object from the cache.  The reference counter associated
   --  with the object is decremented.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Record_Access);

   --  Remove the object from the cache.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Ref);

   --  Remove the object from the cache.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Key);

   --  Remove all object in the cache.
   procedure Remove_All (Cache : in out Object_Cache);

private

   use Ada.Containers;

   --  The cache is a Hashed_Set in which the object record pointers
   --  are stored.  The hash and comparison methods are based on the object key
   --  and object type.
   function Hash (Item : Object_Record_Access) return Hash_Type;

   --  Compare whether the two objects pointed to by Left and Right have the same
   --  object key.
   function Equivalent_Elements (Left, Right : Object_Record_Access)
                               return Boolean;

   package Object_Set is new Indefinite_Hashed_Sets
     (Element_Type        => Object_Record_Access,
      Hash                => Hash,
      Equivalent_Elements => Equivalent_Elements);

   type Object_Cache is new Ada.Finalization.Limited_Controlled with record
      Objects : Object_Set.Set;
   end record;

   --  Finalize the object cache by removing all entries
   overriding
   procedure Finalize (Cache : in out Object_Cache);

end ADO.Objects.Cache;

-----------------------------------------------------------------------
--  objects.cache -- Object cache
--  Copyright (C) 2009, 2010, 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 Ada.Finalization;

with Ada.Containers.Indefinite_Hashed_Sets;

--  The ADO.Objects.Cache holds a cache of object records.
--  The cache maintains a set of objects that were loaded for a given session.
--
--  The cache is not thread-safe.  It is not intended to be shared directly.
package ADO.Objects.Cache is

   type Object_Cache is limited private;

   --  Insert the object in the cache.
   --  The reference counter associated with the object is incremented.
   procedure Insert (Cache  : in out Object_Cache;
                     Object : in Object_Record_Access);

   --  Insert the object in the cache
   --  The reference counter associated with the object is incremented.
   procedure Insert (Cache  : in out Object_Cache;
                     Object : in Object_Ref'Class);

   --  Check if the object is contained in the cache
   function Contains (Cache : in Object_Cache;
                      Key   : in Object_Key) return Boolean;

   function Find (Cache : in Object_Cache;
                  Key   : in Object_Key) return Object_Record_Access;

   procedure Find (Cache  : in Object_Cache;
                   Object : in out Object_Ref'Class;
                   Key    : in Object_Key);

   --  Remove the object from the cache.  The reference counter associated
   --  with the object is decremented.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Record_Access);

   --  Remove the object from the cache.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Ref);

   --  Remove the object from the cache.
   --  Do nothing if the object is not in the cache.
   procedure Remove (Cache  : in out Object_Cache;
                     Object : in Object_Key);

   --  Remove all object in the cache.
   procedure Remove_All (Cache : in out Object_Cache);

private

   use Ada.Containers;

   --  The cache is a Hashed_Set in which the object record pointers
   --  are stored.  The hash and comparison methods are based on the object key
   --  and object type.
   function Hash (Item : Object_Record_Access) return Hash_Type;

   --  Compare whether the two objects pointed to by Left and Right have the same
   --  object key.
   function Equivalent_Elements (Left, Right : Object_Record_Access)
                               return Boolean;

   package Object_Set is new Indefinite_Hashed_Sets
     (Element_Type        => Object_Record_Access,
      Hash                => Hash,
      Equivalent_Elements => Equivalent_Elements);

   type Object_Cache is new Ada.Finalization.Limited_Controlled with record
      Objects : Object_Set.Set;
   end record;

   --  Finalize the object cache by removing all entries
   overriding
   procedure Finalize (Cache : in out Object_Cache);

end ADO.Objects.Cache;

Fix compilation warning with GCC 12: remove unused with clause for an ancestor