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

with Ada.IO_Exceptions;

with ADO.Sessions.Sources;
with ADO.Configs;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with Security.Policies;

with ASF.Server;
with ASF.Servlets;

with AWA.Services.Contexts;
with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
with AWA.Permissions.Services;
with AWA.Permissions.Beans;
package body AWA.Applications is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Applications");

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Initializing application");

      Ctx.Set_Context (App'Unchecked_Access, null);
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      --  Load the application configuration before any module.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Config_File.P));

      --  Register the application modules and load their configuration.
      Application'Class (App).Initialize_Modules;

      --  Load the plugin application configuration after the module are configured.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Plugin_Config_File.P));
   end Initialize;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
      Connection : ADO.Sessions.Sources.Data_Source;
   begin
      Log.Info ("Initializing configuration");

      if Conf.Get ("app.modules.dir", "") = "" then
         Conf.Set ("app.modules.dir", "#{fn:composePath(app_search_dirs,'config')}");
      end if;
      if Conf.Get ("bundle.dir", "") = "" then
         Conf.Set ("bundle.dir", "#{fn:composePath(app_search_dirs,'bundles')}");
      end if;
      if Conf.Get ("ado.queries.paths", "") = "" then
         Conf.Set ("ado.queries.paths", "#{fn:composePath(app_search_dirs,'db')}");
      end if;
      ADO.Configs.Initialize (Conf);
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      Connection.Set_Connection (Conf.Get (P_Database.P));
      Connection.Set_Property ("ado.queries.paths", Conf.Get ("ado.queries.paths", ""));
      Connection.Set_Property ("ado.queries.load", Conf.Get ("ado.queries.load", ""));
      App.DB_Factory.Create (Connection);
      App.DB_Factory.Set_Audit_Manager (App.Audits'Unchecked_Access);
      App.Audits.Initialize (App'Unchecked_Access);
      App.Events.Initialize (App'Unchecked_Access);
      AWA.Modules.Initialize (App.Modules, Conf);

      --  Use a specific error message when the NO_PERMISSION exception is raised.
      App.Get_Exception_Handler.Set_Message ("AWA.PERMISSIONS.NO_PERMISSION",
                                             "layout.exception_no_permission");

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);

      App.Register_Class ("AWA.Permissions.Beans.Permission_Bean",
                          AWA.Permissions.Beans.Create_Permission_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets");

      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters");

      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register_Functions is
         new ASF.Applications.Main.Register_Functions (AWA.Permissions.Services.Set_Functions);
   begin
      Log.Info ("Initializing application components");

      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
      Register_Functions (App);
   end Initialize_Components;

   --  ------------------------------
   --  Read the application configuration file awa.xml.  This is called after the servlets
   --  and filters have been registered in the application but before the module registration.
   --  ------------------------------
   procedure Load_Configuration (App   : in out Application;
                                 Files : in String) is
      procedure Load_Config (File : in String;
                             Done : out Boolean);

      Paths     : constant String := App.Get_Config (P_Module_Dir.P);
      Ctx       : aliased EL.Contexts.Default.Default_Context;

      procedure Load_Config (File : in String;
                             Done : out Boolean) is
         Path  : constant String := Util.Files.Find_File_Path (File, Paths);
      begin
         Done := False;
         AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access, True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Application configuration file '{0}' does not exist", Path);

      end Load_Config;

   begin
      Util.Files.Iterate_Path (Files, Load_Config'Access);
   end Load_Configuration;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Start the application.  This is called by the server container when the server is started.
   --  ------------------------------
   overriding
   procedure Start (App : in out Application) is
      Manager : constant Security.Policies.Policy_Manager_Access
        := App.Get_Security_Manager;
   begin
      --  Start the security manager.
      AWA.Permissions.Services.Permission_Manager'Class (Manager.all).Start;

      --  Start the event service.
      App.Events.Start;

      --  Start the application.
      ASF.Applications.Main.Application (App).Start;

      --  Dump the route and filters to help in configuration issues.
      App.Dump_Routes (Util.Log.INFO_LEVEL);
   end Start;

   --  ------------------------------
   --  Close the application.
   --  ------------------------------
   overriding
   procedure Close (App : in out Application) is
   begin
      App.Events.Stop;
      ASF.Applications.Main.Application (App).Close;
   end Close;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (App : Application)
                         return ADO.Sessions.Session is
   begin
      return App.DB_Factory.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (App : Application)
                                return ADO.Sessions.Master_Session is
   begin
      return App.DB_Factory.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

   --  ------------------------------
   --  Execute the <tt>Process</tt> procedure with the event manager used by the application.
   --  ------------------------------
   procedure Do_Event_Manager (App : in out Application;
                               Process : access procedure
                                 (Events : in out AWA.Events.Services.Event_Manager)) is
   begin
      Process (App.Events);
   end Do_Event_Manager;

   --  ------------------------------
   --  Initialize the parser represented by Parser to recognize the configuration
   --  that are specific to the plugins that have been registered so far.
   --  ------------------------------
   procedure Initialize_Parser (App : in out Application'Class;
                                Parser : in out Util.Serialize.IO.Parser'Class) is
      procedure Process (Module : in out AWA.Modules.Module'Class);

      procedure Process (Module : in out AWA.Modules.Module'Class) is
      begin
         Module.Initialize_Parser (Parser);
      end Process;
   begin
      AWA.Modules.Iterate (App.Modules, Process'Access);
   end Initialize_Parser;

   --  ------------------------------
   --  Get the current application from the servlet context or service context.
   --  ------------------------------
   function Current return Application_Access is
      use type AWA.Services.Contexts.Service_Context_Access;

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
   begin
      if Ctx /= null then
         return Ctx.Get_Application;
      end if;

      --  If there is no service context, look in the servlet current context.
      declare
         use type ASF.Servlets.Servlet_Registry_Access;

         Ctx : constant ASF.Servlets.Servlet_Registry_Access := ASF.Server.Current;
      begin
         if Ctx = null then
            Log.Warn ("There is no service context");
            return null;
         end if;
         if not (Ctx.all in AWA.Applications.Application'Class) then
            Log.Warn ("The servlet context is not an application");
            return null;
         end if;
         return AWA.Applications.Application'Class (Ctx.all)'Access;
      end;
   end Current;

end AWA.Applications;

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

with Ada.IO_Exceptions;

with ADO.Sessions.Sources;
with ADO.Configs;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with Security.Policies;

with ASF.Server;
with ASF.Servlets;

with AWA.Services.Contexts;
with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
with AWA.Permissions.Services;
with AWA.Permissions.Beans;
package body AWA.Applications is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Applications");

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Initializing application");

      Ctx.Set_Context (App'Unchecked_Access, null);
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      --  Load the application configuration before any module.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Config_File.P));

      --  Register the application modules and load their configuration.
      Application'Class (App).Initialize_Modules;

      --  Load the plugin application configuration after the module are configured.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Plugin_Config_File.P));
   end Initialize;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
      Connection : ADO.Sessions.Sources.Data_Source;
   begin
      Log.Info ("Initializing configuration");

      if Conf.Get ("app.modules.dir", "") = "" then
         Conf.Set ("app.modules.dir", "#{fn:composePath(app_search_dirs,'config')}");
      end if;
      if Conf.Get ("bundle.dir", "") = "" then
         Conf.Set ("bundle.dir", "#{fn:composePath(app_search_dirs,'bundles')}");
      end if;
      if Conf.Get ("ado.queries.paths", "") = "" then
         Conf.Set ("ado.queries.paths", "#{fn:composePath(app_search_dirs,'db')}");
      end if;
      ADO.Configs.Initialize (Conf);
      Log.Info ("Using application search dir: {0}", Conf.Get ("app_search_dirs", ""));

      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      Connection.Set_Connection (Conf.Get (P_Database.P));
      Connection.Set_Property ("ado.queries.paths", Conf.Get ("ado.queries.paths", ""));
      Connection.Set_Property ("ado.queries.load", Conf.Get ("ado.queries.load", ""));
      App.DB_Factory.Create (Connection);
      App.DB_Factory.Set_Audit_Manager (App.Audits'Unchecked_Access);
      App.Audits.Initialize (App'Unchecked_Access);
      App.Events.Initialize (App'Unchecked_Access);
      AWA.Modules.Initialize (App.Modules, Conf);

      --  Use a specific error message when the NO_PERMISSION exception is raised.
      App.Get_Exception_Handler.Set_Message ("AWA.PERMISSIONS.NO_PERMISSION",
                                             "layout.exception_no_permission");

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);

      App.Register_Class ("AWA.Permissions.Beans.Permission_Bean",
                          AWA.Permissions.Beans.Create_Permission_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets");

      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters");

      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register_Functions is
         new ASF.Applications.Main.Register_Functions (AWA.Permissions.Services.Set_Functions);
   begin
      Log.Info ("Initializing application components");

      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
      Register_Functions (App);
   end Initialize_Components;

   --  ------------------------------
   --  Read the application configuration file awa.xml.  This is called after the servlets
   --  and filters have been registered in the application but before the module registration.
   --  ------------------------------
   procedure Load_Configuration (App   : in out Application;
                                 Files : in String) is
      procedure Load_Config (File : in String;
                             Done : out Boolean);

      Paths     : constant String := App.Get_Config (P_Module_Dir.P);
      Ctx       : aliased EL.Contexts.Default.Default_Context;

      procedure Load_Config (File : in String;
                             Done : out Boolean) is
         Path  : constant String := Util.Files.Find_File_Path (File, Paths);
      begin
         Done := False;
         AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access, True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Application configuration file '{0}' does not exist", Path);

      end Load_Config;

   begin
      Util.Files.Iterate_Path (Files, Load_Config'Access);
   end Load_Configuration;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Start the application.  This is called by the server container when the server is started.
   --  ------------------------------
   overriding
   procedure Start (App : in out Application) is
      Manager : constant Security.Policies.Policy_Manager_Access
        := App.Get_Security_Manager;
   begin
      --  Start the security manager.
      AWA.Permissions.Services.Permission_Manager'Class (Manager.all).Start;

      --  Start the event service.
      App.Events.Start;

      --  Start the application.
      ASF.Applications.Main.Application (App).Start;

      --  Dump the route and filters to help in configuration issues.
      App.Dump_Routes (Util.Log.INFO_LEVEL);
   end Start;

   --  ------------------------------
   --  Close the application.
   --  ------------------------------
   overriding
   procedure Close (App : in out Application) is
   begin
      App.Events.Stop;
      ASF.Applications.Main.Application (App).Close;
   end Close;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (App : Application)
                         return ADO.Sessions.Session is
   begin
      return App.DB_Factory.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (App : Application)
                                return ADO.Sessions.Master_Session is
   begin
      return App.DB_Factory.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

   --  ------------------------------
   --  Execute the <tt>Process</tt> procedure with the event manager used by the application.
   --  ------------------------------
   procedure Do_Event_Manager (App : in out Application;
                               Process : access procedure
                                 (Events : in out AWA.Events.Services.Event_Manager)) is
   begin
      Process (App.Events);
   end Do_Event_Manager;

   --  ------------------------------
   --  Initialize the parser represented by Parser to recognize the configuration
   --  that are specific to the plugins that have been registered so far.
   --  ------------------------------
   procedure Initialize_Parser (App : in out Application'Class;
                                Parser : in out Util.Serialize.IO.Parser'Class) is
      procedure Process (Module : in out AWA.Modules.Module'Class);

      procedure Process (Module : in out AWA.Modules.Module'Class) is
      begin
         Module.Initialize_Parser (Parser);
      end Process;
   begin
      AWA.Modules.Iterate (App.Modules, Process'Access);
   end Initialize_Parser;

   --  ------------------------------
   --  Get the current application from the servlet context or service context.
   --  ------------------------------
   function Current return Application_Access is
      use type AWA.Services.Contexts.Service_Context_Access;

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
   begin
      if Ctx /= null then
         return Ctx.Get_Application;
      end if;

      --  If there is no service context, look in the servlet current context.
      declare
         use type ASF.Servlets.Servlet_Registry_Access;

         Ctx : constant ASF.Servlets.Servlet_Registry_Access := ASF.Server.Current;
      begin
         if Ctx = null then
            Log.Warn ("There is no service context");
            return null;
         end if;
         if not (Ctx.all in AWA.Applications.Application'Class) then
            Log.Warn ("The servlet context is not an application");
            return null;
         end if;
         return AWA.Applications.Application'Class (Ctx.all)'Access;
      end;
   end Current;

end AWA.Applications;

Add log message to print the application search path


-- RUN: %llvmgcc -c %s
with System;
procedure Negative_Field_Offset (N : Integer) is
   type String_Pointer is access String;
   --  Force use of a thin pointer.
   for String_Pointer'Size use System.Word_Size;
   P : String_Pointer;
begin
   P := new String (1 .. N);
end;

-- RUN: %llvmgcc -c %s
with System;
procedure Negative_Field_Offset (N : Integer) is
   type String_Pointer is access String;
   --  Force use of a thin pointer.
   for String_Pointer'Size use System.Word_Size;
   P : String_Pointer;

   procedure Q (P : String_Pointer) is
   begin
      P (1) := 'Z';
   end;
begin
   P := new String (1 .. N);
   Q (P);
end;

Check that accessing a struct field that occurs before the start
of the struct (!) works correctly.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@84853 91177308-0d34-0410-b5e6-96231b3b80d8


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

with ASF.Contexts.Faces;
with ASF.Utils;
package ASF.Applications.Messages.Factory is

   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String;

   --  Build a localized message.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with one argument.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with two argument.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with some arguments.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Add a localized global message in the current faces context.
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR);

   --  Add a localized field message in the current faces context.  The message is associated
   --  with the component identified by <tt>Client_Id</tt>.
   procedure Add_Field_Message (Client_Id  : in String;
                                Message_Id : in String;
                                Severity   : in Messages.Severity := ERROR);

   --  Add a localized global message in the faces context.
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR);

   --  Add a localized global message in the faces context.
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR);

end ASF.Applications.Messages.Factory;

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

with ASF.Contexts.Faces;
package ASF.Applications.Messages.Factory is

   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String;

   --  Build a localized message.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with one argument.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with two argument.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Build a localized message and format the message with some arguments.
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message;

   --  Add a localized global message in the current faces context.
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR);

   --  Add a localized field message in the current faces context.  The message is associated
   --  with the component identified by <tt>Client_Id</tt>.
   procedure Add_Field_Message (Client_Id  : in String;
                                Message_Id : in String;
                                Severity   : in Messages.Severity := ERROR);

   --  Add a localized global message in the faces context.
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR);

   --  Add a localized global message in the faces context.
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR);

end ASF.Applications.Messages.Factory;

Update to use Format_Summary

Update to use Format_Summary


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

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

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

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

   use Util.Tests;

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

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

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

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

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

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

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

   end Test_Find_Entity_Type;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end ADO.Schemas.Tests;

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

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

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

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

   use Util.Tests;

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

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

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

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

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

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

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

   end Test_Find_Entity_Type;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end ADO.Schemas.Tests;

Update the schema test due to new tables


------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, 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.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access
      is
         Result : Node_Access;
      begin
         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => null);
               Result.Child := Dup_List (N.Child, Result);
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Close_List;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp,
           Position => N,
           Opening => N.Kind = List_Node,
           Stack => <>,
           Locked => False);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null or Object.Locked then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
   begin
      if Object.Locked then
         return 0;
      else
         return Absolute_Level (Object)
           - Lockable.Current_Level (Object.Stack);
      end if;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null or Object.Locked then
         Event := Events.End_Of_Input;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;

      if Event = Events.Close_List
        and then Object.Absolute_Level < Lockable.Current_Level (Object.Stack)
      then
         Event := Events.End_Of_Input;
         Object.Locked := True;
      end if;
   end Next;

   -----------------------------------
   -- Lockable.Descriptor Interface --
   -----------------------------------

   function Absolute_Level (Object : Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      if Object.Position /= null
        and then Object.Position.Kind = List_Node
        and then Object.Opening
      then
         Result := Result + 1;
      end if;

      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Absolute_Level;

   overriding procedure Lock
     (Object : in out Cursor;
      State : out Lockable.Lock_State) is
   begin
      Lockable.Push_Level (Object.Stack, Object.Absolute_Level, State);
   end Lock;

   overriding procedure Unlock
     (Object : in out Cursor;
      State : in out Lockable.Lock_State;
      Finish : in Boolean := True)
   is
      Previous_Level : constant Natural
        := Lockable.Current_Level (Object.Stack);
   begin
      Lockable.Pop_Level (Object.Stack, State);
      State := Lockable.Null_State;
      Object.Locked := False;

      if Finish then
         declare
            Event : Events.Event := Object.Current_Event;
         begin
            loop
               case Event is
                  when Events.Add_Atom | Events.Open_List =>
                     null;
                  when Events.Close_List =>
                     exit when Object.Absolute_Level < Previous_Level;
                  when Events.Error | Events.End_Of_Input =>
                     exit;
               end case;
               Object.Next (Event);
            end loop;
         end;
      end if;

      Object.Locked
        := Object.Absolute_Level < Lockable.Current_Level (Object.Stack);
   end Unlock;

end Natools.S_Expressions.Generic_Caches;

------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, 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.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access
      is
         Result : Node_Access;
      begin
         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => null);
               Result.Child := Dup_List (N.Child, Result);
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      if not Output.Exp.Is_Empty then
         Output.Exp.Update.Data.Close_List;
      end if;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp,
           Position => N,
           Opening => N.Kind = List_Node,
           Stack => <>,
           Locked => False);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null or Object.Locked then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
   begin
      if Object.Locked then
         return 0;
      else
         return Absolute_Level (Object)
           - Lockable.Current_Level (Object.Stack);
      end if;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node
        or else Object.Locked
      then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null or Object.Locked then
         Event := Events.End_Of_Input;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;

      if Event = Events.Close_List
        and then Object.Absolute_Level < Lockable.Current_Level (Object.Stack)
      then
         Event := Events.End_Of_Input;
         Object.Locked := True;
      end if;
   end Next;

   -----------------------------------
   -- Lockable.Descriptor Interface --
   -----------------------------------

   function Absolute_Level (Object : Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      if Object.Position /= null
        and then Object.Position.Kind = List_Node
        and then Object.Opening
      then
         Result := Result + 1;
      end if;

      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Absolute_Level;

   overriding procedure Lock
     (Object : in out Cursor;
      State : out Lockable.Lock_State) is
   begin
      Lockable.Push_Level (Object.Stack, Object.Absolute_Level, State);
   end Lock;

   overriding procedure Unlock
     (Object : in out Cursor;
      State : in out Lockable.Lock_State;
      Finish : in Boolean := True)
   is
      Previous_Level : constant Natural
        := Lockable.Current_Level (Object.Stack);
   begin
      Lockable.Pop_Level (Object.Stack, State);
      State := Lockable.Null_State;
      Object.Locked := False;

      if Finish then
         declare
            Event : Events.Event := Object.Current_Event;
         begin
            loop
               case Event is
                  when Events.Add_Atom | Events.Open_List =>
                     null;
                  when Events.Close_List =>
                     exit when Object.Absolute_Level < Previous_Level;
                  when Events.Error | Events.End_Of_Input =>
                     exit;
               end case;
               Object.Next (Event);
            end loop;
         end;
      end if;

      Object.Locked
        := Object.Absolute_Level < Lockable.Current_Level (Object.Stack);
   end Unlock;

end Natools.S_Expressions.Generic_Caches;

s_expressions-generic_caches: fix incorrect handling of Open_List and Close_List on brand new cache objects


-----------------------------------------------------------------------
--  components-root -- ASF Root View Component
--  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 ASF.Components.Base;
with ASF.Components.Core.Views;
package body ASF.Components.Root is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Get the root node of the view.
   --  ------------------------------
   function Get_Root (UI : in UIViewRoot) return access Base.UIComponent'Class is
   begin
      if UI.Root = null then
         return null;
      elsif UI.Root.Meta = null then
         return UI.Root.View;
      else
         return UI.Root.Meta;
      end if;
   end Get_Root;

   --  ------------------------------
   --  Set the root node of the view.
   --  ------------------------------
   procedure Set_Root (UI   : in out UIViewRoot;
                       Root : access Base.UIComponent'Class;
                       Name : in String) is
   begin
      if UI.Root /= null then
         Finalize (UI);
      end if;

      UI.Root := new Root_Holder '(Ref_Counter => 1,
                                   Len         => Name'Length,
                                   View        => Root,
                                   Meta        => null,
                                   Name        => Name);
   end Set_Root;

   --  ------------------------------
   --  Set the metadata component of the view.
   --  ------------------------------
   procedure Set_Meta (UI   : in out UIViewRoot) is
      Node : access Base.UIComponent'Class;
   begin
      if UI.Root /= null then
         Node := UI.Root.View;
         UI.Root.Meta := Node.Get_Facet (Core.Views.METADATA_FACET_NAME);
         if UI.Root.Meta = null then
            declare
               Iter : Base.Cursor := Base.First (Node.all);
            begin
               while Base.Has_Element (Iter) loop
                  UI.Root.Meta := Base.Element (Iter).Get_Facet (Core.Views.METADATA_FACET_NAME);
                  exit when UI.Root.Meta /= null;
                  Base.Next (Iter);
               end loop;
            end;
         end if;
         if UI.Root.Meta /= null then
            Node.Log_Error ("Found metadata");
         end if;
      end if;
   end Set_Meta;

   --  ------------------------------
   --  Returns True if the view has a metadata component.
   --  ------------------------------
   function Has_Meta (UI : in UIViewRoot) return Boolean is
   begin
      return UI.Root /= null and then UI.Root.Meta /= null;
   end Has_Meta;

   --  ------------------------------
   --  Get the view identifier.
   --  ------------------------------
   function Get_View_Id (UI : in UIViewRoot) return String is
   begin
      return UI.Root.Name;
   end Get_View_Id;

   --  ------------------------------
   --  Create an identifier for a component.
   --  ------------------------------
   procedure Create_Unique_Id (UI : in out UIViewRoot;
                               Id : out Natural) is
   begin
      UI.Last_Id := UI.Last_Id + 1;
      Id := UI.Last_Id;
   end Create_Unique_Id;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out UIViewRoot) is
   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter + 1;
      end if;
   end Adjust;

   Empty : ASF.Components.Base.UIComponent;

   --  ------------------------------
   --  Free the memory held by the component tree.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out UIViewRoot) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Root_Holder,
                                        Name   => Root_Holder_Access);

   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter - 1;
         if Object.Root.Ref_Counter = 0 then
            declare
               C : ASF.Components.Base.UIComponent_Access := Object.Root.View.all'Unchecked_Access;
            begin
               ASF.Components.Base.Steal_Root_Component (Empty, C);
            end;
            Free (Object.Root);
         end if;
      end if;
   end Finalize;

end ASF.Components.Root;

-----------------------------------------------------------------------
--  components-root -- ASF Root View Component
--  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 ASF.Components.Base;
with ASF.Components.Core.Views;
package body ASF.Components.Root is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Get the root node of the view.
   --  ------------------------------
   function Get_Root (UI : in UIViewRoot) return access Base.UIComponent'Class is
   begin
      if UI.Root = null then
         return null;
      elsif UI.Root.Meta = null then
         return UI.Root.View;
      else
         return UI.Root.Meta;
      end if;
   end Get_Root;

   --  ------------------------------
   --  Set the root node of the view.
   --  ------------------------------
   procedure Set_Root (UI   : in out UIViewRoot;
                       Root : access Base.UIComponent'Class;
                       Name : in String) is
   begin
      if UI.Root /= null then
         Finalize (UI);
      end if;

      UI.Root := new Root_Holder '(Ref_Counter => 1,
                                   Len         => Name'Length,
                                   View        => Root,
                                   Meta        => null,
                                   Name        => Name);
   end Set_Root;

   --  ------------------------------
   --  Set the metadata component of the view.
   --  ------------------------------
   procedure Set_Meta (UI   : in out UIViewRoot) is
      Node : access Base.UIComponent'Class;
   begin
      if UI.Root /= null then
         Node := UI.Root.View;
         UI.Root.Meta := Node.Get_Facet (Core.Views.METADATA_FACET_NAME);
         if UI.Root.Meta = null then
            declare
               Iter : Base.Cursor := Base.First (Node.all);
            begin
               while Base.Has_Element (Iter) loop
                  UI.Root.Meta := Base.Element (Iter).Get_Facet (Core.Views.METADATA_FACET_NAME);
                  exit when UI.Root.Meta /= null;
                  Base.Next (Iter);
               end loop;
            end;
         end if;
      end if;
   end Set_Meta;

   --  ------------------------------
   --  Returns True if the view has a metadata component.
   --  ------------------------------
   function Has_Meta (UI : in UIViewRoot) return Boolean is
   begin
      return UI.Root /= null and then UI.Root.Meta /= null;
   end Has_Meta;

   --  ------------------------------
   --  Get the view identifier.
   --  ------------------------------
   function Get_View_Id (UI : in UIViewRoot) return String is
   begin
      return UI.Root.Name;
   end Get_View_Id;

   --  ------------------------------
   --  Create an identifier for a component.
   --  ------------------------------
   procedure Create_Unique_Id (UI : in out UIViewRoot;
                               Id : out Natural) is
   begin
      UI.Last_Id := UI.Last_Id + 1;
      Id := UI.Last_Id;
   end Create_Unique_Id;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out UIViewRoot) is
   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter + 1;
      end if;
   end Adjust;

   Empty : ASF.Components.Base.UIComponent;

   --  ------------------------------
   --  Free the memory held by the component tree.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out UIViewRoot) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Root_Holder,
                                        Name   => Root_Holder_Access);

   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter - 1;
         if Object.Root.Ref_Counter = 0 then
            declare
               C : ASF.Components.Base.UIComponent_Access := Object.Root.View.all'Unchecked_Access;
            begin
               ASF.Components.Base.Steal_Root_Component (Empty, C);
            end;
            Free (Object.Root);
         end if;
      end if;
   end Finalize;

end ASF.Components.Root;

Remove a debug message

Remove a debug message