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

with Ada.IO_Exceptions;

with ASF.Beans;

with ADO.Drivers;

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

with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
package body AWA.Applications is

   use Util.Log;

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

   --  ------------------------------
   --  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
   begin
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      Application'Class (App).Initialize_Modules;
      App.Load_Configuration;
   end Initialize;

   --  ------------------------------
   --  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
      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
      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
   begin
      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
   end Initialize_Components;

   --  ------------------------------
   --  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
   begin
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      declare
         DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
      begin
         App.Events.Initialize (DB);
      end;
      AWA.Modules.Initialize (App.Modules, Conf);

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

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

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Load_Configuration (App : in out Application) is
      Paths : constant String := App.Get_Config (P_Module_Dir.P);
      Base  : constant String := App.Get_Config (P_Config_File.P);
      Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      Ctx   : aliased EL.Contexts.Default.Default_Context;
   begin
      AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access);

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

   --  ------------------------------
   --  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
--        procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
--        procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory) is
--        begin
--           Module.Register_Factory (Factory);
--        end Set_Beans;
--
--        procedure Register_Beans is
--           new ASF.Applications.Main.Register_Beans (Set_Beans);
   begin
      --  Module.Initialize ();
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);

--        Register_Beans (App);
--        App.View.Register_Module (Module);  SCz: 2011-08-10: must check if necessary
   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;

end AWA.Applications;

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

with Ada.IO_Exceptions;

with ADO.Drivers;

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

with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
package body AWA.Applications is

   use Util.Log;

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

   --  ------------------------------
   --  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
   begin
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      Application'Class (App).Initialize_Modules;
      App.Load_Configuration;
   end Initialize;

   --  ------------------------------
   --  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
      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
      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
   begin
      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
   end Initialize_Components;

   --  ------------------------------
   --  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
   begin
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      declare
         DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
      begin
         App.Events.Initialize (DB);
      end;
      AWA.Modules.Initialize (App.Modules, Conf);

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

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

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Load_Configuration (App : in out Application) is
      Paths : constant String := App.Get_Config (P_Module_Dir.P);
      Base  : constant String := App.Get_Config (P_Config_File.P);
      Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      Ctx   : aliased EL.Contexts.Default.Default_Context;
   begin
      AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access);

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

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

end AWA.Applications;

Remove unused commented code

Remove unused commented code


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

   type Postgresql_Driver is limited private;

   --  Initialize the Postgresql driver.
   procedure Initialize;

private

   --  Create a new Postgresql connection using the configuration parameters.
   procedure Create_Connection (D      : in out Postgresql_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

   type Postgresql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Postgresql driver.
   overriding
   procedure Finalize (D : in out Postgresql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String;
      Server_Name : Unbounded_String;
      Login_Name  : Unbounded_String;
      Password    : Unbounded_String;
      Server      : PQ.PGconn_Access := PQ.Null_PGconn;
      Connected   : Boolean      := False;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL      : in Query_String);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   overriding
   procedure Finalize (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

end ADO.Drivers.Connections.Postgresql;

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

   type Postgresql_Driver is limited private;

   --  Initialize the Postgresql driver.
   procedure Initialize;

private

   --  Create a new Postgresql connection using the configuration parameters.
   procedure Create_Connection (D      : in out Postgresql_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

   type Postgresql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Postgresql driver.
   overriding
   procedure Finalize (D : in out Postgresql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String;
      Server_Name : Unbounded_String;
      Login_Name  : Unbounded_String;
      Password    : Unbounded_String;
      Server      : PQ.PGconn_Access := PQ.Null_PGconn;
      Connected   : Boolean      := False;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL      : in Query_String);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   overriding
   procedure Finalize (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  Create the database and initialize it with the schema SQL file.
   overriding
   procedure Create_Database (Database    : in Database_Connection;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector);

end ADO.Drivers.Connections.Postgresql;

Declare the Create_Database procedure

Declare the Create_Database procedure


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

with Ada.Unchecked_Deallocation;

--  The <b>ASF.Sessions</b> package is an Ada implementation of the
--  Java servlet Specification (See JSR 315 at jcp.org).
package body ASF.Sessions is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Returns true if the session is valid.
   --  ------------------------------
   function Is_Valid (Sess : in Session'Class) return Boolean is
   begin
      return Sess.Impl /= null and then Sess.Impl.Is_Active;
   end Is_Valid;

   --  ------------------------------
   --  Returns a string containing the unique identifier assigned to this session.
   --  The identifier is assigned by the servlet container and is implementation dependent.
   --  ------------------------------
   function Get_Id (Sess : in Session) return String is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Id.all;
      end if;
   end Get_Id;

   --  ------------------------------
   --  Returns the last time the client sent a request associated with this session,
   --  as the number of milliseconds since midnight January 1, 1970 GMT, and marked
   --  by the time the container recieved the request.
   --
   --  Actions that your application takes, such as getting or setting a value associated
   --  with the session, do not affect the access time.
   --  ------------------------------
   function Get_Last_Accessed_Time (Sess : in Session) return Ada.Calendar.Time is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Access_Time;
      end if;
   end Get_Last_Accessed_Time;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Sess : in Session) return Duration is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Max_Inactive;
      end if;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Sess     : in Session;
                                        Interval : in Duration) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         Sess.Impl.Max_Inactive := Interval;
      end if;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Returns the object bound with the specified name in this session,
   --  or null if no object is bound under the name.
   --  ------------------------------
   function Get_Attribute (Sess : in Session;
                           Name : in String) return EL.Objects.Object is
      Key : constant Unbounded_String := To_Unbounded_String (Name);
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      Sess.Impl.Lock.Read;
      declare
         Pos : constant EL.Objects.Maps.Cursor := Sess.Impl.Attributes.Find (Key);
      begin
         if EL.Objects.Maps.Has_Element (Pos) then
            return Value : constant EL.Objects.Object := EL.Objects.Maps.Element (Pos) do
               Sess.Impl.Lock.Release_Read;
            end return;
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Read;
            raise;
      end;
      Sess.Impl.Lock.Release_Read;
      return EL.Objects.Null_Object;
   end Get_Attribute;

   --  ------------------------------
   --  Binds an object to this session, using the name specified.
   --  If an object of the same name is already bound to the session,
   --  the object is replaced.
   --
   --  If the value passed in is null, this has the same effect as calling
   --  removeAttribute().
   --  ------------------------------
   procedure Set_Attribute (Sess  : in out Session;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      declare
         Key : constant Unbounded_String := To_Unbounded_String (Name);
      begin
         Sess.Impl.Lock.Write;
         if EL.Objects.Is_Null (Value) then
            Sess.Impl.Attributes.Delete (Key);
         else
            Sess.Impl.Attributes.Include (Key, Value);
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Write;
            raise;
      end;
      Sess.Impl.Lock.Release_Write;
   end Set_Attribute;

   --  ------------------------------
   --  Removes the object bound with the specified name from this session.
   --  If the session does not have an object bound with the specified name,
   --  this method does nothing.
   --  ------------------------------
   procedure Remove_Attribute (Sess : in out Session;
                               Name : in String) is
   begin
      Set_Attribute (Sess, Name, EL.Objects.Null_Object);
   end Remove_Attribute;

   --  ------------------------------
   --  Gets the principal that authenticated to the session.
   --  Returns null if there is no principal authenticated.
   --  ------------------------------
   function Get_Principal (Sess : in Session) return ASF.Principals.Principal_Access is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      return Sess.Impl.Principal;
   end Get_Principal;

   --  ------------------------------
   --  Sets the principal associated with the session.
   --  ------------------------------
   procedure Set_Principal (Sess      : in out Session;
                            Principal : in ASF.Principals.Principal_Access) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      Sess.Impl.Principal := Principal;
   end Set_Principal;

   --  ------------------------------
   --  Invalidates this session then unbinds any objects bound to it.
   --  ------------------------------
   procedure Invalidate (Sess : in out Session) is
   begin
      if Sess.Impl /= null then
         Sess.Impl.Is_Active := False;
         Finalize (Sess);
      end if;
   end Invalidate;

   --  ------------------------------
   --  Adjust (increment) the session record reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Ref_Counter);
      end if;
   end Adjust;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Session_Record'Class,
                                     Name   => Session_Record_Access);

   --  ------------------------------
   --  Decrement the session record reference counter and free the session record
   --  if this was the last session reference.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Session) is
      Release : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Ref_Counter, Release);
         if Release then
            Free (Object.Impl);
         else
            Object.Impl := null;
         end if;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out Session_Record) is
   begin
      Free (Object.Id);
   end Finalize;

end ASF.Sessions;

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

with Ada.Unchecked_Deallocation;

--  The <b>ASF.Sessions</b> package is an Ada implementation of the
--  Java servlet Specification (See JSR 315 at jcp.org).
package body ASF.Sessions is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Returns true if the session is valid.
   --  ------------------------------
   function Is_Valid (Sess : in Session'Class) return Boolean is
   begin
      return Sess.Impl /= null and then Sess.Impl.Is_Active;
   end Is_Valid;

   --  ------------------------------
   --  Returns a string containing the unique identifier assigned to this session.
   --  The identifier is assigned by the servlet container and is implementation dependent.
   --  ------------------------------
   function Get_Id (Sess : in Session) return String is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Id.all;
      end if;
   end Get_Id;

   --  ------------------------------
   --  Returns the last time the client sent a request associated with this session,
   --  as the number of milliseconds since midnight January 1, 1970 GMT, and marked
   --  by the time the container recieved the request.
   --
   --  Actions that your application takes, such as getting or setting a value associated
   --  with the session, do not affect the access time.
   --  ------------------------------
   function Get_Last_Accessed_Time (Sess : in Session) return Ada.Calendar.Time is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Access_Time;
      end if;
   end Get_Last_Accessed_Time;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Sess : in Session) return Duration is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Max_Inactive;
      end if;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Sess     : in Session;
                                        Interval : in Duration) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         Sess.Impl.Max_Inactive := Interval;
      end if;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Returns the object bound with the specified name in this session,
   --  or null if no object is bound under the name.
   --  ------------------------------
   function Get_Attribute (Sess : in Session;
                           Name : in String) return EL.Objects.Object is
      Key : constant Unbounded_String := To_Unbounded_String (Name);
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      Sess.Impl.Lock.Read;
      declare
         Pos : constant EL.Objects.Maps.Cursor := Sess.Impl.Attributes.Find (Key);
      begin
         if EL.Objects.Maps.Has_Element (Pos) then
            return Value : constant EL.Objects.Object := EL.Objects.Maps.Element (Pos) do
               Sess.Impl.Lock.Release_Read;
            end return;
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Read;
            raise;
      end;
      Sess.Impl.Lock.Release_Read;
      return EL.Objects.Null_Object;
   end Get_Attribute;

   --  ------------------------------
   --  Binds an object to this session, using the name specified.
   --  If an object of the same name is already bound to the session,
   --  the object is replaced.
   --
   --  If the value passed in is null, this has the same effect as calling
   --  removeAttribute().
   --  ------------------------------
   procedure Set_Attribute (Sess  : in out Session;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      declare
         Key : constant Unbounded_String := To_Unbounded_String (Name);
      begin
         Sess.Impl.Lock.Write;
         if EL.Objects.Is_Null (Value) then
            Sess.Impl.Attributes.Delete (Key);
         else
            Sess.Impl.Attributes.Include (Key, Value);
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Write;
            raise;
      end;
      Sess.Impl.Lock.Release_Write;
   end Set_Attribute;

   --  ------------------------------
   --  Removes the object bound with the specified name from this session.
   --  If the session does not have an object bound with the specified name,
   --  this method does nothing.
   --  ------------------------------
   procedure Remove_Attribute (Sess : in out Session;
                               Name : in String) is
   begin
      Set_Attribute (Sess, Name, EL.Objects.Null_Object);
   end Remove_Attribute;

   --  ------------------------------
   --  Gets the principal that authenticated to the session.
   --  Returns null if there is no principal authenticated.
   --  ------------------------------
   function Get_Principal (Sess : in Session) return ASF.Principals.Principal_Access is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      return Sess.Impl.Principal;
   end Get_Principal;

   --  ------------------------------
   --  Sets the principal associated with the session.
   --  ------------------------------
   procedure Set_Principal (Sess      : in out Session;
                            Principal : in ASF.Principals.Principal_Access) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      Sess.Impl.Principal := Principal;
   end Set_Principal;

   --  ------------------------------
   --  Invalidates this session then unbinds any objects bound to it.
   --  ------------------------------
   procedure Invalidate (Sess : in out Session) is
   begin
      if Sess.Impl /= null then
         Sess.Impl.Is_Active := False;
         Finalize (Sess);
      end if;
   end Invalidate;

   --  ------------------------------
   --  Adjust (increment) the session record reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Ref_Counter);
      end if;
   end Adjust;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Session_Record'Class,
                                     Name   => Session_Record_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Principals.Principal'Class,
                                     Name   => ASF.Principals.Principal_Access);

   --  ------------------------------
   --  Decrement the session record reference counter and free the session record
   --  if this was the last session reference.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Session) is
      Release : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Ref_Counter, Release);
         if Release then
            Free (Object.Impl.Principal);
            Free (Object.Impl);
         else
            Object.Impl := null;
         end if;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out Session_Record) is
   begin
      Free (Object.Id);
   end Finalize;

end ASF.Sessions;

Delete the principal object when the session is deleted.


with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;

procedure Main is
   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);
begin

   Status := My_VFS.Mount (Path       => "test1",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;
   Status := My_VFS2.Mount (Path       => "test2",
                            Filesystem => My_VFS3'Unchecked_Access);

   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Unlink ("/test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("//test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1//no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1/test2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;
end Main;

with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;

procedure Main is

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname);

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname) is
      Status : Status_Kind;
      DH : Directory_Handle_Ref;
   begin
      Status := FS.Open_Directory (Path, DH);
      if Status /= Status_Ok then
         Semihosting.Log_Line ("Open Directory '" & Path & "' Error: " & Status'Img);
      else
         declare
            Ent : Directory_Entry;
            Index : Positive := 1;
         begin

            Semihosting.Log_Line ("Listing '" & Path & "' content:");
            loop
               Status := DH.Read_Entry (Index, Ent);
               if Status = Status_Ok then
                  Semihosting.Log_Line (" - '" & DH.Entry_Name (Index) & "'");
                  Semihosting.Log_Line ("   Kind: " & Ent.Entry_Type'Img);
               else
                  exit;
               end if;
               Index := Index + 1;
            end loop;
         end;
      end if;
   end List_Dir;

   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);

begin

   Status := My_VFS.Mount (Path       => "test1",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;
   Status := My_VFS2.Mount (Path       => "test2",
                            Filesystem => My_VFS3'Unchecked_Access);

   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Unlink ("/test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("//test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1//no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1/test2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;

   List_Dir (My_VFS, "/");
   List_Dir (My_VFS, "/test1");
   List_Dir (My_VFS, "/test1/");
end Main;

Add directory listing example

example/filesystem: Add directory listing example


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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number : Natural := 0;
      Table  : Table_Definition_Access;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique   : Boolean := False;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name : Unbounded_String;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Column_Definition);

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Association_Definition);

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   package Table_Vectors is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Table_Definition_Access);
   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;
      Has_Associations : Boolean := False;

      --  The list of tables that this table depends on.
      Dependencies     : Table_Vectors.Vector;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;

      --  Mark flag used by the dependency calculation.
      Has_Mark         : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Table_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Table_Definition);

   --  Collect the dependencies to other tables.
   procedure Collect_Dependencies (O : in out Table_Definition);

   type Dependency_Type is (NONE, FORWARD, BACKWARD);  -- CIRCULAR is not yet managed.

   --  Get the dependency between the two tables.
   --  Returns NONE if both table don't depend on each other.
   --  Returns FORWARD if the <tt>Left</tt> table depends on <tt>Right</tt>.
   --  Returns BACKWARD if the <tt>Right</tt> table depends on <tt>Left</tt>.
   function Depends_On (Left, Right : in Table_Definition_Access) return Dependency_Type;

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number   : Natural := 0;
      Table    : Table_Definition_Access;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type  : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name   : Unbounded_String;

      --  The SQL length for strings.
      Sql_Length : Positive := 255;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique    : Boolean := False;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Column_Definition);

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Association_Definition);

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   package Table_Vectors is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Table_Definition_Access);
   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;
      Has_Associations : Boolean := False;

      --  The list of tables that this table depends on.
      Dependencies     : Table_Vectors.Vector;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;

      --  Mark flag used by the dependency calculation.
      Has_Mark         : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Table_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Table_Definition);

   --  Collect the dependencies to other tables.
   procedure Collect_Dependencies (O : in out Table_Definition);

   type Dependency_Type is (NONE, FORWARD, BACKWARD);  -- CIRCULAR is not yet managed.

   --  Get the dependency between the two tables.
   --  Returns NONE if both table don't depend on each other.
   --  Returns FORWARD if the <tt>Left</tt> table depends on <tt>Right</tt>.
   --  Returns BACKWARD if the <tt>Right</tt> table depends on <tt>Left</tt>.
   function Depends_On (Left, Right : in Table_Definition_Access) return Dependency_Type;

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

Add the SQL length to control the length of some SQL types


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

with Ada.Strings.Unbounded;
with Ada.Finalization;

with Util.Properties;

with AWS.SMTP;
with AWS.SMTP.Authentication.Plain;
private with AWS.Attachments;

--  The AWA.Mail.Clients.AWS_SMTP package provides an implementation of the
--  mail client interfaces on top of AWS SMTP client API.
package AWA.Mail.Clients.AWS_SMTP is

   NAME : constant String := "smtp";

   --  ------------------------------
   --  Mail Message
   --  ------------------------------
   --  The Mail_Message represents an abstract mail message that can be initialized
   --  before being sent.
   type AWS_Mail_Message is new Ada.Finalization.Limited_Controlled and Mail_Message with private;
   type AWS_Mail_Message_Access is access all AWS_Mail_Message'Class;

   --  Set the <tt>From</tt> part of the message.
   overriding
   procedure Set_From (Message : in out AWS_Mail_Message;
                       Name    : in String;
                       Address : in String);

   --  Add a recipient for the message.
   overriding
   procedure Add_Recipient (Message : in out AWS_Mail_Message;
                            Kind    : in Recipient_Type;
                            Name    : in String;
                            Address : in String);

   --  Set the subject of the message.
   overriding
   procedure Set_Subject (Message : in out AWS_Mail_Message;
                          Subject : in String);

   --  Set the body of the message.
   overriding
   procedure Set_Body (Message      : in out AWS_Mail_Message;
                       Content      : in Unbounded_String;
                       Alternative  : in Unbounded_String;
                       Content_Type : in String);

   --  Add an attachment with the given content.
   overriding
   procedure Add_Attachment (Message      : in out AWS_Mail_Message;
                             Content      : in Unbounded_String;
                             Content_Id   : in String;
                             Content_Type : in String);

   --  Send the email message.
   overriding
   procedure Send (Message : in out AWS_Mail_Message);

   --  Deletes the mail message.
   overriding
   procedure Finalize (Message : in out AWS_Mail_Message);

   --  ------------------------------
   --  Mail Manager
   --  ------------------------------
   --  The Mail_Manager is the entry point to create a new mail message
   --  and be able to send it.
   type AWS_Mail_Manager is new Mail_Manager with private;
   type AWS_Mail_Manager_Access is access all AWS_Mail_Manager'Class;

   --  Create a SMTP based mail manager and configure it according to the properties.
   function Create_Manager (Props : in Util.Properties.Manager'Class) return Mail_Manager_Access;

   --  Create a new mail message.
   overriding
   function Create_Message (Manager : in AWS_Mail_Manager) return Mail_Message_Access;

private

   type Recipients_Access is access all AWS.SMTP.Recipients;

   type AWS_Mail_Message is new Ada.Finalization.Limited_Controlled and Mail_Message with record
      Manager     : AWS_Mail_Manager_Access;
      From        : AWS.SMTP.E_Mail_Data;
      Subject     : Ada.Strings.Unbounded.Unbounded_String;
      --  Content     : Ada.Strings.Unbounded.Unbounded_String;
      To          : Recipients_Access := null;
      Attachments : AWS.Attachments.List;
   end record;

   type AWS_Mail_Manager is new Mail_Manager with record
      Self    : AWS_Mail_Manager_Access;
      Server  : AWS.SMTP.Receiver;
      Creds   : aliased AWS.SMTP.Authentication.Plain.Credential;
      Port    : Positive := 25;
      Enable  : Boolean := True;
      Secure  : Boolean := False;
      Auth    : Boolean := False;
   end record;

   procedure Initialize (Client : in out AWS_Mail_Manager'Class;
                         Props  : in Util.Properties.Manager'Class);

end AWA.Mail.Clients.AWS_SMTP;

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

with Ada.Strings.Unbounded;
with Ada.Finalization;

with Util.Properties;

with AWS.SMTP;
with AWS.SMTP.Authentication.Plain;
private with AWS.Attachments;

--  The AWA.Mail.Clients.AWS_SMTP package provides an implementation of the
--  mail client interfaces on top of AWS SMTP client API.
package AWA.Mail.Clients.AWS_SMTP is

   NAME : constant String := "smtp";

   --  ------------------------------
   --  Mail Message
   --  ------------------------------
   --  The Mail_Message represents an abstract mail message that can be initialized
   --  before being sent.
   type AWS_Mail_Message is new Ada.Finalization.Limited_Controlled and Mail_Message with private;
   type AWS_Mail_Message_Access is access all AWS_Mail_Message'Class;

   --  Set the <tt>From</tt> part of the message.
   overriding
   procedure Set_From (Message : in out AWS_Mail_Message;
                       Name    : in String;
                       Address : in String);

   --  Add a recipient for the message.
   overriding
   procedure Add_Recipient (Message : in out AWS_Mail_Message;
                            Kind    : in Recipient_Type;
                            Name    : in String;
                            Address : in String);

   --  Set the subject of the message.
   overriding
   procedure Set_Subject (Message : in out AWS_Mail_Message;
                          Subject : in String);

   --  Set the body of the message.
   overriding
   procedure Set_Body (Message      : in out AWS_Mail_Message;
                       Content      : in Unbounded_String;
                       Alternative  : in Unbounded_String;
                       Content_Type : in String);

   --  Add an attachment with the given content.
   overriding
   procedure Add_Attachment (Message      : in out AWS_Mail_Message;
                             Content      : in Unbounded_String;
                             Content_Id   : in String;
                             Content_Type : in String);

   --  Send the email message.
   overriding
   procedure Send (Message : in out AWS_Mail_Message);

   --  Deletes the mail message.
   overriding
   procedure Finalize (Message : in out AWS_Mail_Message);

   --  ------------------------------
   --  Mail Manager
   --  ------------------------------
   --  The Mail_Manager is the entry point to create a new mail message
   --  and be able to send it.
   type AWS_Mail_Manager is new Mail_Manager with private;
   type AWS_Mail_Manager_Access is access all AWS_Mail_Manager'Class;

   --  Create a SMTP based mail manager and configure it according to the properties.
   function Create_Manager (Props : in Util.Properties.Manager'Class) return Mail_Manager_Access;

   --  Create a new mail message.
   overriding
   function Create_Message (Manager : in AWS_Mail_Manager) return Mail_Message_Access;

private

   type Recipients_Access is access all AWS.SMTP.Recipients;

   type Recipients_Array is array (Recipient_Type) of Recipients_Access;

   type AWS_Mail_Message is new Ada.Finalization.Limited_Controlled and Mail_Message with record
      Manager     : AWS_Mail_Manager_Access;
      From        : AWS.SMTP.E_Mail_Data;
      Subject     : Ada.Strings.Unbounded.Unbounded_String;
      To          : Recipients_Array;
      Attachments : AWS.Attachments.List;
   end record;

   type AWS_Mail_Manager is new Mail_Manager with record
      Self    : AWS_Mail_Manager_Access;
      Server  : AWS.SMTP.Receiver;
      Creds   : aliased AWS.SMTP.Authentication.Plain.Credential;
      Port    : Positive := 25;
      Enable  : Boolean := True;
      Secure  : Boolean := False;
      Auth    : Boolean := False;
   end record;

   procedure Initialize (Client : in out AWS_Mail_Manager'Class;
                         Props  : in Util.Properties.Manager'Class);

end AWA.Mail.Clients.AWS_SMTP;

Declare Recipients_Array type to define the TO, CC, BCC recipients


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

with Util.Properties.Factories;
with Ada.Strings.Unbounded.Text_IO;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False);

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, +Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & To_String (Name) & "'";
      end if;

      return Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return -Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return -Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
      Prop_Name : constant Value := +Name;
   begin
      if Exists (Self, Prop_Name) then
         return Get (Self, Prop_Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         Util.Properties.Factories.Initialize (Self);
         Self.Impl.Count := 1;
      elsif Self.Impl.Count > 1 then
         declare
            Old : constant Interface_P.Manager_Access := Self.Impl;
         begin
            Self.Impl := Create_Copy (Self.Impl.all);
            Self.Impl.Count := 1;
            Old.Count := Old.Count - 1;
         end;
      end if;
   end Check_And_Create_Impl;

   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Insert (Self.Impl.all, +Name, +Item);
   end Insert;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, +Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, Name, Item);
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Remove (Self.Impl.all, Name);
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value)) is
   begin
      if Self.Impl /= null then
         Self.Impl.Iterate (Process);
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count - 1;
         if Object.Impl.Count = 0 then
            Delete (Object.Impl.all, Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
         Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False) is
      pragma Unreferenced (Strip);

      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 and then Prefix'Length > 0 and then Index (Line, Prefix) = 1 then
               Name  := Unbounded_Slice (Line, Prefix'Length + 1, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            elsif Pos > 0 and Prefix'Length = 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File, Prefix, Strip);
         exit when Name = Null_Unbounded_String;
         Set (Self, Name, Value);
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F, Prefix, Strip);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When <b>Strip</b> is True,
   --  the prefix part is removed from the property name.
   --  ------------------------------
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False) is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               if Strip and Prefix'Length > 0 then
                  declare
                     S : constant String := Slice (Name, Prefix'Length + 1, Length (Name));
                  begin
                     Self.Set (+(S), From.Get (Name));
                  end;
               else
                  Self.Set (Name, From.Get (Name));
               end if;
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

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

with Util.Properties.Factories;
with Ada.Strings.Unbounded.Text_IO;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False);

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, +Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & To_String (Name) & "'";
      end if;

      return Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return -Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return -Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
      Prop_Name : constant Value := +Name;
   begin
      if Exists (Self, Prop_Name) then
         return Get (Self, Prop_Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         Util.Properties.Factories.Initialize (Self);
      elsif Util.Concurrent.Counters.Value (Self.Impl.Count) > 1 then
         declare
            Old     : Interface_P.Manager_Access := Self.Impl;
            Is_Zero : Boolean;
         begin
            Self.Impl := Create_Copy (Self.Impl.all);
            Util.Concurrent.Counters.Increment (Self.Impl.Count);
            Util.Concurrent.Counters.Decrement (Old.Count, Is_Zero);
            if Is_Zero then
               Delete (Old.all, Old);
            end if;
         end;
      end if;
   end Check_And_Create_Impl;

   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Insert (Self.Impl.all, +Name, +Item);
   end Insert;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, +Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, Name, Item);
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Check_And_Create_Impl (Self);
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Check_And_Create_Impl (Self);
      Remove (Self.Impl.all, Name);
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value)) is
   begin
      if Self.Impl /= null then
         Self.Impl.Iterate (Process);
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Count);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Count, Is_Zero);
         if Is_Zero then
            Delete (Object.Impl.all, Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
--           Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False) is
      pragma Unreferenced (Strip);

      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 and then Prefix'Length > 0 and then Index (Line, Prefix) = 1 then
               Name  := Unbounded_Slice (Line, Prefix'Length + 1, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            elsif Pos > 0 and Prefix'Length = 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File, Prefix, Strip);
         exit when Name = Null_Unbounded_String;
         Set (Self, Name, Value);
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F, Prefix, Strip);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When <b>Strip</b> is True,
   --  the prefix part is removed from the property name.
   --  ------------------------------
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False) is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               if Strip and Prefix'Length > 0 then
                  declare
                     S : constant String := Slice (Name, Prefix'Length + 1, Length (Name));
                  begin
                     Self.Set (+(S), From.Get (Name));
                  end;
               else
                  Self.Set (Name, From.Get (Name));
               end if;
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

Update the implementation to use a concurrent counters for properties manager