--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Ada.Text_IO;
with JohnnyText;
with Definitions;   use Definitions;

package Replicant is

   package JT  renames JohnnyText;
   package TIO renames Ada.Text_IO;

   scenario_unexpected : exception;

   type slave_options is record
      need_procfs    : Boolean := False;
      need_linprocfs : Boolean := False;
   end record;

   --  For every single port to be built, the build need to first be created
   --  and then destroyed when the build is complete.
   procedure launch_slave  (id : builders; opts : slave_options);
   procedure destroy_slave (id : builders; opts : slave_options);

   --  This procedure needs to be run once.
   --  It basically sets the operating system "flavor" which affects the
   --  mount command spawning.  It also creates the password database
   procedure initialize (testmode : Boolean; num_cores : cpu_range);

   --  This removes the password database
   procedure finalize;

   --  Returns True if any mounts are detected (used by pilot)
   function synth_mounts_exist return Boolean;

   --  Returns True if any _work/_localbase dirs are detected (used by pilot)
   function disk_workareas_exist return Boolean;

   --  Returns True if the attempt to clear mounts is successful.
   function clear_existing_mounts return Boolean;

   --  Returns True if the attempt to remove the disk work areas is successful
   function clear_existing_workareas return Boolean;

   --  In order to do scanning in a clean environment prior to the true build
   --  Returns True on success
   function standalone_pkg8_install (id : builders) return Boolean;

   --  The actual command to build a local repository (Returns True on success)
   function build_repository (id : builders; sign_command : String := "")
                              return Boolean;

   --  Returns all the UNAME_x environment variables
   --  They will be passed to the buildcycle package
   function jail_environment return JT.Text;

   --  On FreeBSD, if "/boot" exists but "/boot/modules" does not, return True
   --  This is a pre-run validity check
   function boot_modules_directory_missing return Boolean;

private

   type mount_mode is (readonly, readwrite);
   type nullfs_flavor is (unknown, freebsd, dragonfly);
   type folder_operation is (lock, unlock);
   type folder is (bin, sbin, lib, libexec,
                   usr_bin,
                   usr_include,
                   usr_lib,
                   usr_libdata,
                   usr_libexec,
                   usr_sbin,
                   usr_share,
                   usr_lib32, xports, options, packages, distfiles,
                   dev, etc, etc_default, etc_mtree, etc_rcd, home, linux,
                   proc, root, tmp, var, wrkdirs, usr_local, usr_src, ccache,
                   boot);
   subtype subfolder is folder range bin .. usr_share;

   --  home and root need to be set readonly
   reference_base   : constant String := "Base";
   root_bin         : constant String := "/bin";
   root_sbin        : constant String := "/sbin";
   root_usr_bin     : constant String := "/usr/bin";
   root_usr_include : constant String := "/usr/include";
   root_usr_lib     : constant String := "/usr/lib";
   root_usr_lib32   : constant String := "/usr/lib32";
   root_usr_libdata : constant String := "/usr/libdata";
   root_usr_libexec : constant String := "/usr/libexec";
   root_usr_sbin    : constant String := "/usr/sbin";
   root_usr_share   : constant String := "/usr/share";
   root_usr_src     : constant String := "/usr/src";
   root_dev         : constant String := "/dev";
   root_etc         : constant String := "/etc";
   root_etc_default : constant String := "/etc/defaults";
   root_etc_mtree   : constant String := "/etc/mtree";
   root_etc_rcd     : constant String := "/etc/rc.d";
   root_lib         : constant String := "/lib";
   root_tmp         : constant String := "/tmp";
   root_var         : constant String := "/var";
   root_home        : constant String := "/home";
   root_boot        : constant String := "/boot";
   root_kmodules    : constant String := "/boot/modules";
   root_lmodules    : constant String := "/boot/modules.local";
   root_root        : constant String := "/root";
   root_proc        : constant String := "/proc";
   root_linux       : constant String := "/compat/linux";
   root_linproc     : constant String := "/compat/linux/proc";
   root_xports      : constant String := "/xports";
   root_options     : constant String := "/options";
   root_libexec     : constant String := "/libexec";
   root_wrkdirs     : constant String := "/construction";
   root_packages    : constant String := "/packages";
   root_distfiles   : constant String := "/distfiles";
   root_ccache      : constant String := "/ccache";
   root_localbase   : constant String := "/usr/local";
   chroot           : constant String := "/usr/sbin/chroot ";

   flavor           : nullfs_flavor   := unknown;
   smp_cores        : cpu_range       := cpu_range'First;
   support_locks    : Boolean;
   developer_mode   : Boolean;
   abn_log_ready    : Boolean;
   builder_env      : JT.Text;
   abnormal_log     : TIO.File_Type;

   abnormal_cmd_logname : constant String := "05_abnormal_cmd.out";

   --  Throws exception if mount attempt was unsuccessful
   procedure mount_nullfs (target, mount_point : String;
                           mode : mount_mode := readonly);

   --  Throws exception if mount attempt was unsuccessful
   procedure mount_tmpfs  (mount_point : String; max_size_M : Natural := 0);

   --  Throws exception if unmount attempt was unsuccessful
   procedure unmount (device_or_node : String);

   --  Throws exception if directory was not successfully created
   procedure forge_directory (target : String);

   --  Return the full path of the mount point
   function location (mount_base : String; point : folder) return String;
   function mount_target (point : folder) return String;

   --  Query configuration to determine the master mount
   function get_master_mount return String;
   function get_slave_mount (id : builders) return String;

   --  returns "SLXX" where XX is a zero-padded integer (01 .. 32)
   function slave_name (id : builders) return String;

   --  locks and unlocks folders, even from root
   procedure folder_access (path : String; operation : folder_operation);

   --  self explanatory
   procedure create_symlink (destination, symbolic_link : String);

   --  generic command, throws exception if exit code is not 0
   procedure execute (command : String);
   procedure silent_exec (command : String);
   function  internal_system_command (command : String) return JT.Text;

   --  create slave's /var directory tree.  Path should be an empty directory.
   procedure populate_var_folder (path : String);

   --  create /etc/make.conf in slave
   procedure create_make_conf (path_to_etc : String);

   --  create /etc/passwd (and databases) to define system users
   procedure create_passwd      (path_to_etc : String);
   procedure create_base_passwd (path_to_mm  : String);

   --  create /etc/group to define root user
   procedure create_group      (path_to_etc : String);
   procedure create_base_group (path_to_mm  : String);

   --  copy host's /etc/resolv.conf to slave
   procedure copy_resolv_conf (path_to_etc : String);

   --  copy host's /etc/mtree files to slave
   procedure copy_mtree_files (path_to_mtree : String);

   --  copy host's conf defaults
   procedure copy_rc_default (path_to_etc : String);

   --  create minimal /etc/services
   procedure create_etc_services (path_to_etc : String);

   --  create a dummy fstab for linux packages (looks for linprocfs)
   procedure create_etc_fstab (path_to_etc : String);

   --  mount the devices
   procedure mount_devices (path_to_dev : String);

   --  execute ldconfig as last action of slave creation
   procedure execute_ldconfig (id : builders);

   --  Used for per-profile make.conf fragments (if they exist)
   procedure concatenate_makeconf (makeconf_handle : TIO.File_Type;
                                   target_name : String);

   --  Wrapper for rm -rf <directory>
   procedure annihilate_directory_tree (tree : String);

   --  This is only done for FreeBSD.  For DragonFly, it's a null-op
   procedure mount_linprocfs (mount_point : String);

   --  It turns out at least one major port uses procfs (gnustep)
   procedure mount_procfs (path_to_proc : String);

   --  Cache variables that spawn to get populated to extended make.conf
   procedure cache_port_variables (path_to_mm : String);

   --  Used to generic mtree exclusion files
   procedure write_common_mtree_exclude_base (mtreefile : TIO.File_Type);
   procedure write_preinstall_section (mtreefile : TIO.File_Type);
   procedure create_mtree_exc_preconfig (path_to_mm : String);
   procedure create_mtree_exc_preinst (path_to_mm : String);

   --  Get OSVERSION from <sys/param.h>
   function get_osversion_from_param_header return String;

   --  Derived from /usr/bin/file -b <slave>/bin/sh
   function get_arch_from_bourne_shell return String;

   --  capture unexpected output while setting up builders (e.g. mount)
   procedure start_abnormal_logging;
   procedure stop_abnormal_logging;

end Replicant;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Ada.Text_IO;
with JohnnyText;
with Definitions;   use Definitions;

package Replicant is

   package JT  renames JohnnyText;
   package TIO renames Ada.Text_IO;

   scenario_unexpected : exception;

   type slave_options is record
      need_procfs    : Boolean := False;
      need_linprocfs : Boolean := False;
   end record;

   --  For every single port to be built, the build need to first be created
   --  and then destroyed when the build is complete.
   procedure launch_slave  (id : builders; opts : slave_options);
   procedure destroy_slave (id : builders; opts : slave_options);

   --  This procedure needs to be run once.
   --  It basically sets the operating system "flavor" which affects the
   --  mount command spawning.  It also creates the password database
   procedure initialize (testmode : Boolean; num_cores : cpu_range);

   --  This removes the password database
   procedure finalize;

   --  Returns True if any mounts are detected (used by pilot)
   function synth_mounts_exist return Boolean;

   --  Returns True if any _work/_localbase dirs are detected (used by pilot)
   function disk_workareas_exist return Boolean;

   --  Returns True if the attempt to clear mounts is successful.
   function clear_existing_mounts return Boolean;

   --  Returns True if the attempt to remove the disk work areas is successful
   function clear_existing_workareas return Boolean;

   --  In order to do scanning in a clean environment prior to the true build
   --  Returns True on success
   function standalone_pkg8_install (id : builders) return Boolean;

   --  The actual command to build a local repository (Returns True on success)
   function build_repository (id : builders; sign_command : String := "")
                              return Boolean;

   --  Returns all the UNAME_x environment variables
   --  They will be passed to the buildcycle package
   function jail_environment return JT.Text;

   --  On FreeBSD, if "/boot" exists but "/boot/modules" does not, return True
   --  This is a pre-run validity check
   function boot_modules_directory_missing return Boolean;

private

   type mount_mode is (readonly, readwrite);
   type nullfs_flavor is (unknown, freebsd, dragonfly);
   type folder_operation is (lock, unlock);
   type folder is (bin, sbin, lib, libexec,
                   usr_bin,
                   usr_include,
                   usr_lib,
                   usr_libdata,
                   usr_libexec,
                   usr_sbin,
                   usr_share,
                   usr_lib32, xports, options, packages, distfiles,
                   dev, etc, etc_default, etc_mtree, etc_rcd, home, linux,
                   proc, root, tmp, var, wrkdirs, usr_local, usr_src, ccache,
                   boot);
   subtype subfolder is folder range bin .. usr_share;

   --  home and root need to be set readonly
   reference_base   : constant String := "Base";
   root_bin         : constant String := "/bin";
   root_sbin        : constant String := "/sbin";
   root_usr_bin     : constant String := "/usr/bin";
   root_usr_include : constant String := "/usr/include";
   root_usr_lib     : constant String := "/usr/lib";
   root_usr_lib32   : constant String := "/usr/lib32";
   root_usr_libdata : constant String := "/usr/libdata";
   root_usr_libexec : constant String := "/usr/libexec";
   root_usr_sbin    : constant String := "/usr/sbin";
   root_usr_share   : constant String := "/usr/share";
   root_usr_src     : constant String := "/usr/src";
   root_dev         : constant String := "/dev";
   root_etc         : constant String := "/etc";
   root_etc_default : constant String := "/etc/defaults";
   root_etc_mtree   : constant String := "/etc/mtree";
   root_etc_rcd     : constant String := "/etc/rc.d";
   root_lib         : constant String := "/lib";
   root_tmp         : constant String := "/tmp";
   root_var         : constant String := "/var";
   root_home        : constant String := "/home";
   root_boot        : constant String := "/boot";
   root_kmodules    : constant String := "/boot/modules";
   root_lmodules    : constant String := "/boot/modules.local";
   root_root        : constant String := "/root";
   root_proc        : constant String := "/proc";
   root_linux       : constant String := "/compat/linux";
   root_linproc     : constant String := "/compat/linux/proc";
   root_xports      : constant String := "/xports";
   root_options     : constant String := "/options";
   root_libexec     : constant String := "/libexec";
   root_wrkdirs     : constant String := "/construction";
   root_packages    : constant String := "/packages";
   root_distfiles   : constant String := "/distfiles";
   root_ccache      : constant String := "/ccache";
   root_localbase   : constant String := "/usr/local";
   chroot           : constant String := "/usr/sbin/chroot ";

   flavor           : nullfs_flavor   := unknown;
   smp_cores        : cpu_range       := cpu_range'First;
   support_locks    : Boolean;
   developer_mode   : Boolean;
   abn_log_ready    : Boolean;
   builder_env      : JT.Text;
   abnormal_log     : TIO.File_Type;

   abnormal_cmd_logname : constant String := "05_abnormal_command_output.log";

   --  Throws exception if mount attempt was unsuccessful
   procedure mount_nullfs (target, mount_point : String;
                           mode : mount_mode := readonly);

   --  Throws exception if mount attempt was unsuccessful
   procedure mount_tmpfs  (mount_point : String; max_size_M : Natural := 0);

   --  Throws exception if unmount attempt was unsuccessful
   procedure unmount (device_or_node : String);

   --  Throws exception if directory was not successfully created
   procedure forge_directory (target : String);

   --  Return the full path of the mount point
   function location (mount_base : String; point : folder) return String;
   function mount_target (point : folder) return String;

   --  Query configuration to determine the master mount
   function get_master_mount return String;
   function get_slave_mount (id : builders) return String;

   --  returns "SLXX" where XX is a zero-padded integer (01 .. 32)
   function slave_name (id : builders) return String;

   --  locks and unlocks folders, even from root
   procedure folder_access (path : String; operation : folder_operation);

   --  self explanatory
   procedure create_symlink (destination, symbolic_link : String);

   --  generic command, throws exception if exit code is not 0
   procedure execute (command : String);
   procedure silent_exec (command : String);
   function  internal_system_command (command : String) return JT.Text;

   --  create slave's /var directory tree.  Path should be an empty directory.
   procedure populate_var_folder (path : String);

   --  create /etc/make.conf in slave
   procedure create_make_conf (path_to_etc : String);

   --  create /etc/passwd (and databases) to define system users
   procedure create_passwd      (path_to_etc : String);
   procedure create_base_passwd (path_to_mm  : String);

   --  create /etc/group to define root user
   procedure create_group      (path_to_etc : String);
   procedure create_base_group (path_to_mm  : String);

   --  copy host's /etc/resolv.conf to slave
   procedure copy_resolv_conf (path_to_etc : String);

   --  copy host's /etc/mtree files to slave
   procedure copy_mtree_files (path_to_mtree : String);

   --  copy host's conf defaults
   procedure copy_rc_default (path_to_etc : String);

   --  create minimal /etc/services
   procedure create_etc_services (path_to_etc : String);

   --  create a dummy fstab for linux packages (looks for linprocfs)
   procedure create_etc_fstab (path_to_etc : String);

   --  mount the devices
   procedure mount_devices (path_to_dev : String);

   --  execute ldconfig as last action of slave creation
   procedure execute_ldconfig (id : builders);

   --  Used for per-profile make.conf fragments (if they exist)
   procedure concatenate_makeconf (makeconf_handle : TIO.File_Type;
                                   target_name : String);

   --  Wrapper for rm -rf <directory>
   procedure annihilate_directory_tree (tree : String);

   --  This is only done for FreeBSD.  For DragonFly, it's a null-op
   procedure mount_linprocfs (mount_point : String);

   --  It turns out at least one major port uses procfs (gnustep)
   procedure mount_procfs (path_to_proc : String);

   --  Cache variables that spawn to get populated to extended make.conf
   procedure cache_port_variables (path_to_mm : String);

   --  Used to generic mtree exclusion files
   procedure write_common_mtree_exclude_base (mtreefile : TIO.File_Type);
   procedure write_preinstall_section (mtreefile : TIO.File_Type);
   procedure create_mtree_exc_preconfig (path_to_mm : String);
   procedure create_mtree_exc_preinst (path_to_mm : String);

   --  Get OSVERSION from <sys/param.h>
   function get_osversion_from_param_header return String;

   --  Derived from /usr/bin/file -b <slave>/bin/sh
   function get_arch_from_bourne_shell return String;

   --  capture unexpected output while setting up builders (e.g. mount)
   procedure start_abnormal_logging;
   procedure stop_abnormal_logging;

end Replicant;

Change name of abnormal command output log

The ".out" suffix isn't handled well with apache webserver.


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

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

   type Test_Context_Type is record
      Number  : Integer;
      Success : Boolean := False;
   end record;

   package Test_Command is new
     Util.Commands.Drivers (Context_Type => Test_Context_Type,
                            Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                            Driver_Name  => "test");

   type Test_Command_Type is new Test_Command.Command_Type with record
      Opt_Count : aliased Integer := 0;
      Opt_V     : aliased Boolean := False;
      Opt_N     : aliased Boolean := False;
      Expect_V  : Boolean := False;
      Expect_N  : Boolean := False;
      Expect_C  : Integer := 0;
      Expect_A  : Integer := 0;
      Expect_Help : Boolean := False;
   end record;

   overriding
   procedure Execute (Command   : in Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration);

   --  Write the help associated with the command.
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Execute",
                       Test_Execute'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Help",
                       Test_Help'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Usage",
                       Test_Usage'Access);
   end Add_Tests;

   overriding
   procedure Execute (Command   : in Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type) is
   begin
      Context.Success := Command.Opt_Count = Command.Expect_C and
        Command.Opt_V = Command.Expect_V and
        Command.Opt_N = Command.Expect_N and
        Args.Get_Count = Command.Expect_A and
        not Command.Expect_Help;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration) is
   begin
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-c:",
                                       Long_Switch => "--count=",
                                       Help        => "Number option",
                                       Section     => "",
                                       Initial     => Integer (0),
                                       Default     => Integer (10),
                                       Output      => Command.Opt_Count'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-v",
                                       Long_Switch => "--verbose",
                                       Help        => "Verbose option",
                                       Section     => "",
                                       Output      => Command.Opt_V'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-n",
                                       Long_Switch => "--not",
                                       Help        => "Not option",
                                       Section     => "",
                                       Output      => Command.Opt_N'Access);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type) is

   begin
      Context.Success := Command.Expect_Help;
   end Help;

   --  ------------------------------
   --  Tests when the execution of commands.
   --  ------------------------------
   procedure Test_Execute (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := True;
         C1.Expect_N := True;
         C1.Expect_C := 4;
         C1.Expect_A := 2;
         Initialize (Args, "list --count=4 -v -n test titi");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := False;
         C1.Expect_N := True;
         C1.Expect_C := 8;
         C1.Expect_A := 3;
         Initialize (Args, "list -c 8 -n test titi last");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

   end Test_Execute;

   --  ------------------------------
   --  Test execution of help.
   --  ------------------------------
   procedure Test_Help (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C2.Expect_Help := True;
         Initialize (Args, "help print");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Help;

   --  ------------------------------
   --  Test usage operation.
   --  ------------------------------
   procedure Test_Usage (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      D.Usage (Args);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Usage;

end Util.Commands.Tests;

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

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

   type Test_Context_Type is record
      Number  : Integer;
      Success : Boolean := False;
   end record;

   package Test_Command is new
     Util.Commands.Drivers (Context_Type => Test_Context_Type,
                            Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                            Driver_Name  => "test");

   type Test_Command_Type is new Test_Command.Command_Type with record
      Opt_Count : aliased Integer := 0;
      Opt_V     : aliased Boolean := False;
      Opt_N     : aliased Boolean := False;
      Expect_V  : Boolean := False;
      Expect_N  : Boolean := False;
      Expect_C  : Integer := 0;
      Expect_A  : Integer := 0;
      Expect_Help : Boolean := False;
   end record;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration);

   --  Write the help associated with the command.
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Execute",
                       Test_Execute'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Help",
                       Test_Help'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Usage",
                       Test_Usage'Access);
   end Add_Tests;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type) is
   begin
      Context.Success := Command.Opt_Count = Command.Expect_C and
        Command.Opt_V = Command.Expect_V and
        Command.Opt_N = Command.Expect_N and
        Args.Get_Count = Command.Expect_A and
        not Command.Expect_Help;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration) is
   begin
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-c:",
                                       Long_Switch => "--count=",
                                       Help        => "Number option",
                                       Section     => "",
                                       Initial     => Integer (0),
                                       Default     => Integer (10),
                                       Output      => Command.Opt_Count'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-v",
                                       Long_Switch => "--verbose",
                                       Help        => "Verbose option",
                                       Section     => "",
                                       Output      => Command.Opt_V'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-n",
                                       Long_Switch => "--not",
                                       Help        => "Not option",
                                       Section     => "",
                                       Output      => Command.Opt_N'Access);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type) is

   begin
      Context.Success := Command.Expect_Help;
   end Help;

   --  ------------------------------
   --  Tests when the execution of commands.
   --  ------------------------------
   procedure Test_Execute (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := True;
         C1.Expect_N := True;
         C1.Expect_C := 4;
         C1.Expect_A := 2;
         Initialize (Args, "list --count=4 -v -n test titi");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := False;
         C1.Expect_N := True;
         C1.Expect_C := 8;
         C1.Expect_A := 3;
         Initialize (Args, "list -c 8 -n test titi last");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

   end Test_Execute;

   --  ------------------------------
   --  Test execution of help.
   --  ------------------------------
   procedure Test_Help (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C2.Expect_Help := True;
         Initialize (Args, "help print");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Help;

   --  ------------------------------
   --  Test usage operation.
   --  ------------------------------
   procedure Test_Usage (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      D.Usage (Args);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Usage;

end Util.Commands.Tests;

Change the Execute procedure to use in out parameter for the Command_Type parameter


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

with 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;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers.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 Drivers.Connections.Driver_Access
           := Drivers.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
         use ADO.Drivers;
      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", 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.
      Reader.Parse (Path, Mapper);

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

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

   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.Drivers.Connections.Configuration'Class) is
      Paths : constant String := Config.Get_Property ("ado.queries.paths");
      Load  : constant Boolean := Config.Get_Property ("ado.queries.load") = "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).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, 2012, 2013, 2014, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with 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;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers.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 Drivers.Connections.Driver_Access
           := Drivers.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
         use ADO.Drivers;
      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", 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.
      Reader.Parse (Path, Mapper);

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

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

   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.Drivers.Connections.Configuration'Class) is
      Paths : constant String := Config.Get_Property ("ado.queries.paths");
      Load  : constant Boolean := Config.Get_Property ("ado.queries.load") = "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;

Initialize Last_Modified and Next_Check for each query file