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

with Util.Strings;
with Util.Refs;
with ADO.SQL;
with ADO.Drivers;

private with Interfaces;
with Ada.Strings.Unbounded;
with Ada.Finalization;

--  == Introduction ==
--  Ada Database Objects provides a small framework which helps in
--  using complex SQL queries in an application.
--  The benefit of the framework are the following:
--
--    * The SQL query result are directly mapped in Ada records,
--    * It is easy to change or tune an SQL query without re-building the application,
--    * The SQL query can be easily tuned for a given database
--
--  The database query framework uses an XML query file:
--
--    * The XML query file defines a mapping that represents the result of SQL queries,
--    * The XML mapping is used by [http://code.google.com/p/ada-gen Dynamo] to generate an Ada record,
--    * The XML query file also defines a set of SQL queries, each query being identified by a unique name,
--    * The XML query file is read by the application to obtain the SQL query associated with a query name,
--    * The application uses the `List` procedure generated by [http://code.google.com/p/ada-gen Dynamo].
--
--  == XML Query File and Mapping ==
--  === XML Query File ===
--  The XML query file uses the `query-mapping` root element.  It should
--  define at most one `class` mapping and several `query` definitions.
--  The `class` definition should come first before any `query` definition.
--
--    <query-mapping>
--       <class>...</class>
--       <query>...</query>
--    </query-mapping>
--
--  == SQL Result Mapping ==
--  The XML query mapping is very close to the database table mapping.
--  The difference is that there is no need to specify and table name
--  nor any SQL type.  The XML query mapping is used to build an Ada
--  record that correspond to query results.  Unlike the database table mapping,
--  the Ada record will not be tagged and its definition will expose all the record
--  members directly.
--
--  The following XML query mapping:
--
--    <query-mapping>
--      <class name='Samples.Model.User_Info'>
--        <property name="name" type="String">
--           <comment>the user name</comment>
--        </property>
--        <property name="email" type="String">
--           <comment>the email address</comment>
--        </property>
--      </class>
--    </query-mapping>
--
--  will generate the following Ada record:
--
--    package Samples.Model is
--       type User_Info is record
--         Name  : Unbounded_String;
--         Email : Unbounded_String;
--       end record;
--    end Samples.Model;
--
--  The same query mapping can be used by different queries.
--
--  === SQL Queries ===
--  The XML query file defines a list of SQL queries that the application
--  can use.  Each query is associated with a unique name.  The application
--  will use that name to identify the SQL query to execute.  For each query,
--  the file also describes the SQL query pattern that must be used for
--  the query execution.
--
--    <query name='xxx' class='Samples.Model.User_Info'>
--       <sql driver='mysql'>
--         select u.name, u.email from user
--       </sql>
--       <sql driver='sqlite'>
--          ...
--       </sql>
--       <sql-count driver='mysql'>
--          select count(*) from user u
--       </sql-count>
--    </query>
--
--  The query contains basically two SQL patterns.  The `sql` element represents
--  the main SQL pattern.  This is the SQL that is used by the `List` operation.
--  In some cases, the result set returned by the query is limited to return only
--  a maximum number of rows.  This is often use in paginated lists.
--
--  The `sql-count` element represents an SQL query to indicate the total number
--  of elements if the SQL query was not limited.
package ADO.Queries is

   type Query_Index is new Natural;

   type File_Index is new Natural;

   type Query_File is limited private;
   type Query_File_Access is access all Query_File;

   type Query_Definition is limited private;
   type Query_Definition_Access is access all Query_Definition;

   type Query_Manager is limited new Ada.Finalization.Limited_Controlled with private;
   type Query_Manager_Access is access all Query_Manager;

   --  ------------------------------
   --  Query Context
   --  ------------------------------
   --  The Context type holds the necessary information to build and execute
   --  a query whose SQL pattern is defined in an XML query file.
   type Context is new ADO.SQL.Query with private;

   --  Set the query definition which identifies the SQL query to execute.
   --  The query is represented by the <tt>sql</tt> XML entry.
   procedure Set_Query (Into  : in out Context;
                        Query : in Query_Definition_Access);

   --  Set the query count definition which identifies the SQL query to execute.
   --  The query count is represented by the <tt>sql-count</tt> XML entry.
   procedure Set_Count_Query (Into  : in out Context;
                              Query : in Query_Definition_Access);

   --  Set the query to execute as SQL statement.
   procedure Set_SQL (Into : in out Context;
                      SQL  : in String);

   procedure Set_Query (Into  : in out Context;
                        Name  : in String);

   --  Set the limit for the SQL query.
   procedure Set_Limit (Into  : in out Context;
                        First : in Natural;
                        Last  : in Natural);

   --  Get the first row index.
   function Get_First_Row_Index (From : in Context) return Natural;

   --  Get the last row index.
   function Get_Last_Row_Index (From : in Context) return Natural;

   --  Get the maximum number of rows that the SQL query can return.
   --  This operation uses the sql-count query.
   function Get_Max_Row_Count (From : in Context) return Natural;

   --  Get the SQL query that correspond to the query context.
   function Get_SQL (From    : in Context;
                     Manager : in Query_Manager'Class) return String;

   function Get_SQL (From      : in Query_Definition_Access;
                     Manager   : in Query_Manager;
                     Use_Count : in Boolean) return String;

private

   --  ------------------------------
   --  Query Definition
   --  ------------------------------
   --  The Query_Definition holds the SQL query pattern which is defined
   --  in an XML query file.  The query is identified by a name and a given XML
   --  query file can contain several queries.  The Dynamo generator generates
   --  one instance of Query_Definition for each query defined in the XML
   --  file.  The XML file is loaded during application initialization (or later)
   --  to get the SQL query pattern.  Multi-thread concurrency is achieved by
   --  the Query_Info_Ref atomic reference.
   type Query_Definition is limited record
      --  The query name.
      Name   : Util.Strings.Name_Access;

      --  The query file in which the query is defined.
      File   : Query_File_Access;

      --  The next query defined in the query file.
      Next   : Query_Definition_Access;

      --  The SQL query pattern (initialized when reading the XML query file).
      --  Query  : Query_Info_Ref_Access;
      Query  : Query_Index := 0;
   end record;

   --  ------------------------------
   --  Query File
   --  ------------------------------
   --  The Query_File describes the SQL queries associated and loaded from
   --  a given XML query file.  The Dynamo generator generates one instance of
   --  Query_File for each XML query file that it has read.  The Path,
   --  Sha1_Map, Queries and Next are initialized statically by the generator (during
   --  package elaboration).
   type Query_File is limited record
      --  Query relative path name
      Name          : Util.Strings.Name_Access;

      --  The SHA1 hash of the query map section.
      Sha1_Map      : Util.Strings.Name_Access;

      --  The first query defined for that file.
      Queries       : Query_Definition_Access;

      --  The next XML query file registered in the application.
      Next          : Query_File_Access;

      --  The unique file index.
      File          : File_Index := 0;
   end record;

   type Context is new ADO.SQL.Query with record
      First      : Natural := 0;
      Last       : Natural := 0;
      Last_Index : Natural := 0;
      Max_Row_Count : Natural := 0;
      Query_Def  : Query_Definition_Access := null;
      Is_Count   : Boolean := False;
   end record;

   use Ada.Strings.Unbounded;

   --  SQL query pattern
   type Query_Pattern is limited record
      SQL : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Query_Pattern_Array is array (ADO.Drivers.Driver_Index) of Query_Pattern;

   type Query_Info is new Util.Refs.Ref_Entity with record
      Main_Query  : Query_Pattern_Array;
      Count_Query : Query_Pattern_Array;
   end record;
   type Query_Info_Access is access all Query_Info;

   package Query_Info_Ref is
      new Util.Refs.References (Query_Info, Query_Info_Access);

   type Query_Info_Ref_Access is access all Query_Info_Ref.Atomic_Ref;

   subtype Query_Index_Table is Query_Index range 1 .. Query_Index'Last;
   subtype File_Index_Table is File_Index range 1 .. File_Index'Last;

   type Query_File_Info is record
      --  Query absolute path name (after path resolution).
      Path          : Ada.Strings.Unbounded.Unbounded_String;

      --  File
      File          : Query_File_Access;

      --  Stamp when the query file will be checked.
      Next_Check    : Interfaces.Unsigned_32;

      --  Stamp identifying the modification date of the query file.
      Last_Modified : Interfaces.Unsigned_32;
   end record;

   --  Find the query with the given name.
   --  Returns the query definition that matches the name or null if there is none
   function Find_Query (File : in Query_File_Info;
                        Name : in String) return Query_Definition_Access;

   type Query_Table is array (Query_Index_Table range <>) of Query_Info_Ref.Ref;
   type Query_Table_Access is access all Query_Table;

   type File_Table is array (File_Index_Table range <>) of Query_File_Info;
   type File_Table_Access is access all File_Table;

   type Query_Manager is limited new Ada.Finalization.Limited_Controlled with record
      Driver  : ADO.Drivers.Driver_Index;
      Queries : Query_Table_Access;
      Files   : File_Table_Access;
   end record;

   overriding
   procedure Finalize (Manager : in out Query_Manager);

end ADO.Queries;

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

with Util.Strings;
with Util.Refs;
with ADO.SQL;
with ADO.Drivers;

private with Interfaces;
with Ada.Strings.Unbounded;
with Ada.Finalization;

--  == Named Queries ==
--  Ada Database Objects provides a small framework which helps in
--  using complex SQL queries in an application by using named queries.
--  The benefit of the framework are the following:
--
--    * The SQL query result are directly mapped in Ada records,
--    * It is easy to change or tune an SQL query without re-building the application,
--    * The SQL query can be easily tuned for a given database.
--
--  The database query framework uses an XML query file:
--
--    * The XML query file defines a mapping that represents the result of SQL queries,
--    * The XML mapping is used by Dynamo to generate an Ada record,
--    * The XML query file also defines a set of SQL queries, each query being identified by a unique name,
--    * The XML query file is read by the application to obtain the SQL query associated with a query name,
--    * The application uses the `List` procedure generated by Dynamo.
--
--  === XML Query File ===
--  The XML query file uses the `query-mapping` root element.  It should
--  define at most one `class` mapping and several `query` definitions.
--  The `class` definition should come first before any `query` definition.
--
--    <query-mapping>
--       <class>...</class>
--       <query>...</query>
--    </query-mapping>
--
--  === SQL Result Mapping ===
--  The XML query mapping is very close to the database table mapping.
--  The difference is that there is no need to specify any table name
--  nor any SQL type.  The XML query mapping is used to build an Ada
--  record that correspond to query results.  Unlike the database table mapping,
--  the Ada record will not be tagged and its definition will expose all the record
--  members directly.
--
--  The following XML query mapping:
--
--    <query-mapping>
--      <class name='Samples.Model.User_Info'>
--        <property name="name" type="String">
--           <comment>the user name</comment>
--        </property>
--        <property name="email" type="String">
--           <comment>the email address</comment>
--        </property>
--      </class>
--    </query-mapping>
--
--  will generate the following Ada record:
--
--    package Samples.Model is
--       type User_Info is record
--         Name  : Unbounded_String;
--         Email : Unbounded_String;
--       end record;
--    end Samples.Model;
--
--  The same query mapping can be used by different queries.
--
--  === SQL Queries ===
--  The XML query file defines a list of SQL queries that the application
--  can use.  Each query is associated with a unique name.  The application
--  will use that name to identify the SQL query to execute.  For each query,
--  the file also describes the SQL query pattern that must be used for
--  the query execution.
--
--    <query name='xxx' class='Samples.Model.User_Info'>
--       <sql driver='mysql'>
--         select u.name, u.email from user
--       </sql>
--       <sql driver='sqlite'>
--          ...
--       </sql>
--       <sql-count driver='mysql'>
--          select count(*) from user u
--       </sql-count>
--    </query>
--
--  The query contains basically two SQL patterns.  The `sql` element represents
--  the main SQL pattern.  This is the SQL that is used by the `List` operation.
--  In some cases, the result set returned by the query is limited to return only
--  a maximum number of rows.  This is often use in paginated lists.
--
--  The `sql-count` element represents an SQL query to indicate the total number
--  of elements if the SQL query was not limited.
package ADO.Queries is

   type Query_Index is new Natural;

   type File_Index is new Natural;

   type Query_File is limited private;
   type Query_File_Access is access all Query_File;

   type Query_Definition is limited private;
   type Query_Definition_Access is access all Query_Definition;

   type Query_Manager is limited new Ada.Finalization.Limited_Controlled with private;
   type Query_Manager_Access is access all Query_Manager;

   --  ------------------------------
   --  Query Context
   --  ------------------------------
   --  The Context type holds the necessary information to build and execute
   --  a query whose SQL pattern is defined in an XML query file.
   type Context is new ADO.SQL.Query with private;

   --  Set the query definition which identifies the SQL query to execute.
   --  The query is represented by the <tt>sql</tt> XML entry.
   procedure Set_Query (Into  : in out Context;
                        Query : in Query_Definition_Access);

   --  Set the query count definition which identifies the SQL query to execute.
   --  The query count is represented by the <tt>sql-count</tt> XML entry.
   procedure Set_Count_Query (Into  : in out Context;
                              Query : in Query_Definition_Access);

   --  Set the query to execute as SQL statement.
   procedure Set_SQL (Into : in out Context;
                      SQL  : in String);

   procedure Set_Query (Into  : in out Context;
                        Name  : in String);

   --  Set the limit for the SQL query.
   procedure Set_Limit (Into  : in out Context;
                        First : in Natural;
                        Last  : in Natural);

   --  Get the first row index.
   function Get_First_Row_Index (From : in Context) return Natural;

   --  Get the last row index.
   function Get_Last_Row_Index (From : in Context) return Natural;

   --  Get the maximum number of rows that the SQL query can return.
   --  This operation uses the sql-count query.
   function Get_Max_Row_Count (From : in Context) return Natural;

   --  Get the SQL query that correspond to the query context.
   function Get_SQL (From    : in Context;
                     Manager : in Query_Manager'Class) return String;

   function Get_SQL (From      : in Query_Definition_Access;
                     Manager   : in Query_Manager;
                     Use_Count : in Boolean) return String;

private

   --  ------------------------------
   --  Query Definition
   --  ------------------------------
   --  The Query_Definition holds the SQL query pattern which is defined
   --  in an XML query file.  The query is identified by a name and a given XML
   --  query file can contain several queries.  The Dynamo generator generates
   --  one instance of Query_Definition for each query defined in the XML
   --  file.  The XML file is loaded during application initialization (or later)
   --  to get the SQL query pattern.  Multi-thread concurrency is achieved by
   --  the Query_Info_Ref atomic reference.
   type Query_Definition is limited record
      --  The query name.
      Name   : Util.Strings.Name_Access;

      --  The query file in which the query is defined.
      File   : Query_File_Access;

      --  The next query defined in the query file.
      Next   : Query_Definition_Access;

      --  The SQL query pattern (initialized when reading the XML query file).
      --  Query  : Query_Info_Ref_Access;
      Query  : Query_Index := 0;
   end record;

   --  ------------------------------
   --  Query File
   --  ------------------------------
   --  The Query_File describes the SQL queries associated and loaded from
   --  a given XML query file.  The Dynamo generator generates one instance of
   --  Query_File for each XML query file that it has read.  The Path,
   --  Sha1_Map, Queries and Next are initialized statically by the generator (during
   --  package elaboration).
   type Query_File is limited record
      --  Query relative path name
      Name          : Util.Strings.Name_Access;

      --  The SHA1 hash of the query map section.
      Sha1_Map      : Util.Strings.Name_Access;

      --  The first query defined for that file.
      Queries       : Query_Definition_Access;

      --  The next XML query file registered in the application.
      Next          : Query_File_Access;

      --  The unique file index.
      File          : File_Index := 0;
   end record;

   type Context is new ADO.SQL.Query with record
      First      : Natural := 0;
      Last       : Natural := 0;
      Last_Index : Natural := 0;
      Max_Row_Count : Natural := 0;
      Query_Def  : Query_Definition_Access := null;
      Is_Count   : Boolean := False;
   end record;

   use Ada.Strings.Unbounded;

   --  SQL query pattern
   type Query_Pattern is limited record
      SQL : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Query_Pattern_Array is array (ADO.Drivers.Driver_Index) of Query_Pattern;

   type Query_Info is new Util.Refs.Ref_Entity with record
      Main_Query  : Query_Pattern_Array;
      Count_Query : Query_Pattern_Array;
   end record;
   type Query_Info_Access is access all Query_Info;

   package Query_Info_Ref is
      new Util.Refs.References (Query_Info, Query_Info_Access);

   type Query_Info_Ref_Access is access all Query_Info_Ref.Atomic_Ref;

   subtype Query_Index_Table is Query_Index range 1 .. Query_Index'Last;
   subtype File_Index_Table is File_Index range 1 .. File_Index'Last;

   type Query_File_Info is record
      --  Query absolute path name (after path resolution).
      Path          : Ada.Strings.Unbounded.Unbounded_String;

      --  File
      File          : Query_File_Access;

      --  Stamp when the query file will be checked.
      Next_Check    : Interfaces.Unsigned_32;

      --  Stamp identifying the modification date of the query file.
      Last_Modified : Interfaces.Unsigned_32;
   end record;

   --  Find the query with the given name.
   --  Returns the query definition that matches the name or null if there is none
   function Find_Query (File : in Query_File_Info;
                        Name : in String) return Query_Definition_Access;

   type Query_Table is array (Query_Index_Table range <>) of Query_Info_Ref.Ref;
   type Query_Table_Access is access all Query_Table;

   type File_Table is array (File_Index_Table range <>) of Query_File_Info;
   type File_Table_Access is access all File_Table;

   type Query_Manager is limited new Ada.Finalization.Limited_Controlled with record
      Driver  : ADO.Drivers.Driver_Index;
      Queries : Query_Table_Access;
      Files   : File_Table_Access;
   end record;

   overriding
   procedure Finalize (Manager : in out Query_Manager);

end ADO.Queries;

Add some documentation

Add some documentation


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

with Util.Tests;

package ASF.Servlets.Tests is

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

   type Test_Servlet1 is new Servlet with null record;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class);

   type Test_Servlet2 is new Test_Servlet1 with null record;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class);

   type Test is new Util.Tests.Test with record
      Writer    : Integer;
   end record;

   --  Test creation of session
   procedure Test_Create_Servlet (T : in out Test);

   --  Test add servlet
   procedure Test_Add_Servlet (T : in out Test);

   --  Test getting a resource path
   procedure Test_Get_Resource (T : in out Test);

   procedure Test_Request_Dispatcher (T : in out Test);

   --  Test mapping and servlet path on a request.
   procedure Test_Servlet_Path (T : in out Test);

   --  Test mapping and servlet path on a request.
   procedure Test_Filter_Mapping (T : in out Test);

   --  Check that the mapping for the given URI matches the server.
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access;
                            Filter : in Natural := 0);

   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String);

end ASF.Servlets.Tests;

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

with Util.Tests;

package ASF.Servlets.Tests is

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

   type Test_Servlet1 is new Servlet with null record;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class);

   type Test_Servlet2 is new Test_Servlet1 with null record;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class);

   type Test is new Util.Tests.Test with record
      Writer    : Integer;
   end record;

   --  Test creation of session
   procedure Test_Create_Servlet (T : in out Test);

   --  Test add servlet
   procedure Test_Add_Servlet (T : in out Test);

   --  Test getting a resource path
   procedure Test_Get_Resource (T : in out Test);

   procedure Test_Request_Dispatcher (T : in out Test);

   --  Test mapping and servlet path on a request.
   procedure Test_Servlet_Path (T : in out Test);

   --  Test mapping and servlet path on a request.
   procedure Test_Filter_Mapping (T : in out Test);

   --  Test execution of filters
   procedure Test_Filter_Execution (T : in out Test);

   --  Check that the mapping for the given URI matches the server.
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access;
                            Filter : in Natural := 0);

   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String);

end ASF.Servlets.Tests;

Declare the Test_Filter_Execution procedure


-----------------------------------------------------------------------
--  util-tests-server - A small non-compliant-inefficient HTTP server used for unit tests
--  Copyright (C) 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.Finalization;

package Util.Tests.Servers is

   --  Pool of objects
   type Server is new Ada.Finalization.Limited_Controlled with private;
   type Server_Access is access all Server'Class;

   --  Get the server port.
   function Get_Port (From : in Server) return Natural;

   --  Process the line received by the server.
   procedure Process_Line (Into : in out Server;
                           Line : in Ada.Strings.Unbounded.Unbounded_String);

   --  Start the server task.
   procedure Start (S : in out Server);

private

   --  A small server that listens to HTTP requests and replies with fake
   --  responses.  This server is intended to be used by unit tests and not to serve
   --  real pages.
   task type Server_Task is
      entry Start (S : in Server_Access);
      --        entry Stop;
   end Server_Task;

   type Server is new Ada.Finalization.Limited_Controlled with record
      Port          : Natural := 0;
      Need_Shutdown : Boolean := False;
      Server        : Server_Task;
   end record;

end Util.Tests.Servers;

-----------------------------------------------------------------------
--  util-tests-server - A small non-compliant-inefficient HTTP server used for unit tests
--  Copyright (C) 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.Finalization;

package Util.Tests.Servers is

   --  A small TCP/IP server for unit tests.
   type Server is new Ada.Finalization.Limited_Controlled with private;
   type Server_Access is access all Server'Class;

   --  Get the server port.
   function Get_Port (From : in Server) return Natural;

   --  Process the line received by the server.
   procedure Process_Line (Into : in out Server;
                           Line : in Ada.Strings.Unbounded.Unbounded_String);

   --  Start the server task.
   procedure Start (S : in out Server);

private

   --  A small server that listens to HTTP requests and replies with fake
   --  responses.  This server is intended to be used by unit tests and not to serve
   --  real pages.
   task type Server_Task is
      entry Start (S : in Server_Access);
      --        entry Stop;
   end Server_Task;

   type Server is new Ada.Finalization.Limited_Controlled with record
      Port          : Natural := 0;
      Need_Shutdown : Boolean := False;
      Server        : Server_Task;
   end record;

end Util.Tests.Servers;

Update comment

Update comment


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

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

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      Assert (T, Message'Length > 0,
              "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      Assert (T, Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      Assert (T, False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         Assert (T, Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      Assert (T, Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      Assert (T, not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               Assert (T, Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                       & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      Assert (T, Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            Assert (T, Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      Assert (T, Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

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

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      Assert (T, Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      Assert (T, False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         Assert (T, Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      Assert (T, Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      Assert (T, not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               Assert (T, Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                       & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      Assert (T, Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            Assert (T, Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      Assert (T, Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

Fix compilation with GNAT 2011

Fix compilation with GNAT 2011


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

with Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with Util.Properties;
with Util.Strings;
with Util.Refs;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Util.Refs.Ref_Entity with record
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver index.
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index;

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

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

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

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

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

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

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

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

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

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

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

   package Ref is
      new Util.Refs.Indefinite_References (Element_Type   => Database_Connection'Class,
                                           Element_Access => Database_Connection_Access);

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String);

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String);

   --  Get the server hostname.
   function Get_Server (Controller : in Configuration) return String;

   --  Set the server port.
   procedure Set_Port (Controller : in out Configuration;
                       Port       : in Natural);

   --  Get the server port.
   function Get_Port (Controller : in Configuration) return Natural;

   --  Set the database name.
   procedure Set_Database (Controller : in out Configuration;
                           Database   : in String);

   --  Get the database name.
   function Get_Database (Controller : in Configuration) return String;

   --  Get the database driver name.
   function Get_Driver (Controller : in Configuration) return String;

   --  Get the database driver index.
   function Get_Driver (Controller : in Configuration) return Driver_Index;

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

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

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

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String;
      Log_URI    : Unbounded_String;
      Server     : Unbounded_String;
      Port       : Natural := 0;
      Database   : Unbounded_String;
      Properties : Util.Properties.Manager;
      Driver     : Driver_Access;
   end record;

end ADO.Drivers.Connections;

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

with Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with ADO.Configs;
with Util.Strings;
with Util.Strings.Vectors;
with Util.Refs;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Util.Refs.Ref_Entity with record
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver index.
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index;

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

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

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

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

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

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

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

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

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

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

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

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

   package Ref is
      new Util.Refs.Indefinite_References (Element_Type   => Database_Connection'Class,
                                           Element_Access => Database_Connection_Access);

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new ADO.Configs.Configuration with null record;

   --  Get the driver index that corresponds to the driver for this database connection string.
   function Get_Driver (Config : in Configuration) return Driver_Index;

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

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

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

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

end ADO.Drivers.Connections;

Move the Configuration type in a separate package ADO.Configs so that it is easier to use


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

with Util.Test_Caller;

with Ada.Text_IO;

with Util.Properties;
with Util.Properties.Basic;

package body Util.Properties.Tests is

   use Ada.Text_IO;
   use type Ada.Containers.Count_Type;
   use Util.Properties.Basic;

   --  Test
   --    Properties.Set
   --    Properties.Exists
   --    Properties.Get
   procedure Test_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      T.Assert (Exists (Props, "test") = False,
                "Invalid properties");
      T.Assert (Exists (Props, +("test")) = False,
                "Invalid properties");
      T.Assert (Props.Is_Empty, "Property manager should be empty");
      Props.Set ("test", "toto");
      T.Assert (Exists (Props, "test"),
                "Property was not inserted");
      declare
         V : constant String := Props.Get ("test");
      begin

         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;

      declare
         V : constant String := Props.Get (+("test"));
      begin
         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;

      declare
         V : constant Unbounded_String := Props.Get (+("test"));
      begin
         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;
   end Test_Property;

   --  Test basic properties
   --     Get
   --     Set
   procedure Test_Integer_Property (T : in out Test) is
      Props : Properties.Manager;
      V     : Integer := 23;
   begin
      Integer_Property.Set (Props, "test-integer", V);
      T.Assert (Props.Exists ("test-integer"), "Invalid properties");

      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 23, "Property was not inserted");

      Integer_Property.Set (Props, "test-integer", 24);
      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 24, "Property was not inserted");

      V := Integer_Property.Get (Props, "unknown", 25);
      T.Assert (V = 25, "Default value must be returned for a Get");
   end Test_Integer_Property;

   --  Test loading of property files
   procedure Test_Load_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 30,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("root.dir")) = ".",
                   "Invalid property 'root.dir'");
         T.Assert (To_String (Props.Get ("console.lib")) = "${dist.lib.dir}/console.jar",
                   "Invalid property 'console.lib'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Property;

   --  ------------------------------
   --  Test loading of property files
   --  ------------------------------
   procedure Test_Load_Strip_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      --  Load, filter and strip properties
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F, "tomcat.", True);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 3,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("version")) = "0.6",
                   "Invalid property 'root.dir'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Strip_Property;

   --  ------------------------------
   --  Test copy of properties
   --  ------------------------------
   procedure Test_Copy_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      Props.Set ("prefix.one", "1");
      Props.Set ("prefix.two", "2");
      Props.Set ("prefix", "Not copied");
      Props.Set ("prefix.", "Copied");
      declare
         Copy : Properties.Manager;
      begin
         Copy.Copy (From   => Props,
                    Prefix => "prefix.",
                    Strip  => True);
         T.Assert (Copy.Exists ("one"), "Property one not found");
         T.Assert (Copy.Exists ("two"), "Property two not found");
         T.Assert (Copy.Exists (""), "Property '' does not exist.");
      end;
   end Test_Copy_Property;

   procedure Test_Set_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")), "Invalid property a");
         Props1.Set ("a", "d");
         Util.Tests.Assert_Equals (T, "d", String '(Props1.Get ("a")),
                                   "Wrong property a in props1");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2 := Props1;
         Util.Tests.Assert_Equals (T, "d", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2.Set ("e", "f");
         Props2.Set ("c", "g");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      T.Assert (Props1.Exists ("e"), "Property e not found in props1 after assignment");
      T.Assert (Props1.Exists ("c"), "Property c not found in props1 after assignment");
      Util.Tests.Assert_Equals (T, "g", String '(Props1.Get ("c")),
                                "Wrong property c in props1");
   end Test_Set_Preserve_Original;

   procedure Test_Remove_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Props1.Remove ("a");
         T.Assert (not Props1.Exists ("a"), "Property a was not removed from props1");
         T.Assert (Props2.Exists ("a"), "Property a was removed from props2");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      Util.Tests.Assert_Equals (T, "b", String '(Props1.Get ("a")),
                                "Wrong property a in props1");
   end Test_Remove_Preserve_Original;

   procedure Test_Missing_Property (T : in out Test) is
      Props  : Properties.Manager;
      V      : Unbounded_String;
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;

      begin
         V := Props.Get (+("missing"));
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
      T.Assert (Ada.Strings.Unbounded.Length (V) = 0, "Variable get's corrupted");

      --  Check exception on Get returning a String.
      begin
         declare
            S : constant String := Props.Get ("missing");
            pragma Unreferenced (S);
         begin
            T.Fail ("Exception NO_PROPERTY was not raised");
         end;
      exception
         when NO_PROPERTY =>
            null;
      end;

      --  Check exception on Get returning a String.
      begin
         declare
            S : constant String := Props.Get (+("missing"));
            pragma Unreferenced (S);
         begin
            T.Fail ("Exception NO_PROPERTY was not raised");
         end;
      exception
         when NO_PROPERTY =>
            null;
      end;

      Props.Set ("a", "b");
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
   end Test_Missing_Property;

   procedure Test_Load_Ini_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/files/my.cnf");
      Load_Properties (Props, F);
      Close (F);

      declare
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         V := Props.Get_Value ("mysqld");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");

      end;

      declare
         P : Properties.Manager;
      begin
         P := Props.Get ("mysqld");
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         P := Props.Get ("mysqld_safe");
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");
      end;

      declare
         P : Properties.Manager with Unreferenced;
      begin
         P := Props.Get ("bad");
         T.Fail ("No exception raised for Get()");

      exception
         when NO_PROPERTY =>
            null;
      end;

   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/files/my.cnf");
         raise;

   end Test_Load_Ini_Property;

   procedure Test_Save_Properties (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("save-props.properties");
   begin
      declare
         Props  : Properties.Manager;
         F      : File_Type;
      begin
         Open (F, In_File, "regtests/files/my.cnf");
         Load_Properties (Props, F);
         Close (F);

         Props.Set ("New-Property", "Some-Value");
         Props.Remove ("mysqld");
         T.Assert (not Props.Exists ("mysqld"), "mysqld property was not removed");
         Props.Save_Properties (Path);
      end;

      declare
         Props : Properties.Manager;
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         Props.Load_Properties (Path => Path);

         T.Assert (not Props.Exists ("mysqld"), "mysqld property was not removed (2)");
         T.Assert (Props.Exists ("New-Property"), "Invalid Save_Properties");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");
      end;

      declare
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         P := Util.Properties.To_Manager (V);
         T.Fail ("No exception raised by To_Manager");

      exception
         when Util.Beans.Objects.Conversion_Error =>
            null;
      end;
   end Test_Save_Properties;

   procedure Test_Remove_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      begin
         Props.Remove ("missing");
         T.Fail ("Remove should raise exception");

      exception
         when NO_PROPERTY =>
            null;
      end;

      begin
         Props.Remove (+("missing"));
         T.Fail ("Remove should raise exception");

      exception
         when NO_PROPERTY =>
            null;
      end;

      Props.Set ("a", "b");
      T.Assert (Props.Exists ("a"), "Property not inserted");

      Props.Remove ("a");
      T.Assert (not Props.Exists ("a"), "Property not removed");

      Props.Set ("a", +("b"));
      T.Assert (Props.Exists ("a"), "Property not inserted");

      Props.Remove (+("a"));
      T.Assert (not Props.Exists ("a"), "Property not removed");
   end Test_Remove_Property;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Properties.Set",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Exists",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Remove",
                       Test_Remove_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get (NO_PROPERTY)",
                       Test_Missing_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Get",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Set",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties",
                       Test_Load_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties (INI)",
                       Test_Load_Ini_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Strip_Properties",
                       Test_Load_Strip_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Copy",
                       Test_Copy_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign",
                       Test_Set_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign+Remove",
                       Test_Remove_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Save_Properties",
                       Test_Save_Properties'Access);
   end Add_Tests;

end Util.Properties.Tests;

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

with Util.Test_Caller;

with Ada.Text_IO;

with Util.Properties;
with Util.Properties.Basic;

package body Util.Properties.Tests is

   use Ada.Text_IO;
   use type Ada.Containers.Count_Type;
   use Util.Properties.Basic;

   --  Test
   --    Properties.Set
   --    Properties.Exists
   --    Properties.Get
   procedure Test_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      T.Assert (Exists (Props, "test") = False,
                "Invalid properties");
      T.Assert (Exists (Props, +("test")) = False,
                "Invalid properties");
      T.Assert (Props.Is_Empty, "Property manager should be empty");
      Props.Set ("test", "toto");
      T.Assert (Exists (Props, "test"),
                "Property was not inserted");
      declare
         V : constant String := Props.Get ("test");
      begin

         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;

      declare
         V : constant String := Props.Get (+("test"));
      begin
         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;

      declare
         V : constant Unbounded_String := Props.Get (+("test"));
      begin
         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;
   end Test_Property;

   --  Test basic properties
   --     Get
   --     Set
   procedure Test_Integer_Property (T : in out Test) is
      Props : Properties.Manager;
      V     : Integer := 23;
   begin
      Integer_Property.Set (Props, "test-integer", V);
      T.Assert (Props.Exists ("test-integer"), "Invalid properties");

      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 23, "Property was not inserted");

      Integer_Property.Set (Props, "test-integer", 24);
      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 24, "Property was not inserted");

      V := Integer_Property.Get (Props, "unknown", 25);
      T.Assert (V = 25, "Default value must be returned for a Get");
   end Test_Integer_Property;

   --  Test loading of property files
   procedure Test_Load_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 30,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("root.dir")) = ".",
                   "Invalid property 'root.dir'");
         T.Assert (To_String (Props.Get ("console.lib")) = "${dist.lib.dir}/console.jar",
                   "Invalid property 'console.lib'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Property;

   --  ------------------------------
   --  Test loading of property files
   --  ------------------------------
   procedure Test_Load_Strip_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      --  Load, filter and strip properties
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F, "tomcat.", True);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 3,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("version")) = "0.6",
                   "Invalid property 'root.dir'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Strip_Property;

   --  ------------------------------
   --  Test copy of properties
   --  ------------------------------
   procedure Test_Copy_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      Props.Set ("prefix.one", "1");
      Props.Set ("prefix.two", "2");
      Props.Set ("prefix", "Not copied");
      Props.Set ("prefix.", "Copied");
      declare
         Copy : Properties.Manager;
      begin
         Copy.Copy (From   => Props);
         T.Assert (Copy.Exists ("prefix.one"), "Property one not found");
         T.Assert (Copy.Exists ("prefix.two"), "Property two not found");
         T.Assert (Copy.Exists ("prefix"), "Property '' does not exist.");
         T.Assert (Copy.Exists ("prefix."), "Property '' does not exist.");
      end;

      declare
         Copy : Properties.Manager;
      begin
         Copy.Copy (From   => Props,
                    Prefix => "prefix.",
                    Strip  => True);
         T.Assert (Copy.Exists ("one"), "Property one not found");
         T.Assert (Copy.Exists ("two"), "Property two not found");
         T.Assert (Copy.Exists (""), "Property '' does not exist.");
      end;
   end Test_Copy_Property;

   procedure Test_Set_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")), "Invalid property a");
         Props1.Set ("a", "d");
         Util.Tests.Assert_Equals (T, "d", String '(Props1.Get ("a")),
                                   "Wrong property a in props1");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2 := Props1;
         Util.Tests.Assert_Equals (T, "d", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2.Set ("e", "f");
         Props2.Set ("c", "g");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      T.Assert (Props1.Exists ("e"), "Property e not found in props1 after assignment");
      T.Assert (Props1.Exists ("c"), "Property c not found in props1 after assignment");
      Util.Tests.Assert_Equals (T, "g", String '(Props1.Get ("c")),
                                "Wrong property c in props1");
   end Test_Set_Preserve_Original;

   procedure Test_Remove_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Props1.Remove ("a");
         T.Assert (not Props1.Exists ("a"), "Property a was not removed from props1");
         T.Assert (Props2.Exists ("a"), "Property a was removed from props2");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      Util.Tests.Assert_Equals (T, "b", String '(Props1.Get ("a")),
                                "Wrong property a in props1");
   end Test_Remove_Preserve_Original;

   procedure Test_Missing_Property (T : in out Test) is
      Props  : Properties.Manager;
      V      : Unbounded_String;
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;

      begin
         V := Props.Get (+("missing"));
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
      T.Assert (Ada.Strings.Unbounded.Length (V) = 0, "Variable get's corrupted");

      --  Check exception on Get returning a String.
      begin
         declare
            S : constant String := Props.Get ("missing");
            pragma Unreferenced (S);
         begin
            T.Fail ("Exception NO_PROPERTY was not raised");
         end;
      exception
         when NO_PROPERTY =>
            null;
      end;

      --  Check exception on Get returning a String.
      begin
         declare
            S : constant String := Props.Get (+("missing"));
            pragma Unreferenced (S);
         begin
            T.Fail ("Exception NO_PROPERTY was not raised");
         end;
      exception
         when NO_PROPERTY =>
            null;
      end;

      Props.Set ("a", "b");
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
   end Test_Missing_Property;

   procedure Test_Load_Ini_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/files/my.cnf");
      Load_Properties (Props, F);
      Close (F);

      declare
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         V := Props.Get_Value ("mysqld");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");

      end;

      declare
         P : Properties.Manager;
      begin
         P := Props.Get ("mysqld");
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         P := Props.Get ("mysqld_safe");
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");
      end;

      declare
         P : Properties.Manager with Unreferenced;
      begin
         P := Props.Get ("bad");
         T.Fail ("No exception raised for Get()");

      exception
         when NO_PROPERTY =>
            null;
      end;

   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/files/my.cnf");
         raise;

   end Test_Load_Ini_Property;

   procedure Test_Save_Properties (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("save-props.properties");
   begin
      declare
         Props  : Properties.Manager;
         F      : File_Type;
      begin
         Open (F, In_File, "regtests/files/my.cnf");
         Load_Properties (Props, F);
         Close (F);

         Props.Set ("New-Property", "Some-Value");
         Props.Remove ("mysqld");
         T.Assert (not Props.Exists ("mysqld"), "mysqld property was not removed");
         Props.Save_Properties (Path);
      end;

      declare
         Props : Properties.Manager;
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         Props.Load_Properties (Path => Path);

         T.Assert (not Props.Exists ("mysqld"), "mysqld property was not removed (2)");
         T.Assert (Props.Exists ("New-Property"), "Invalid Save_Properties");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");
      end;

      declare
         V : Util.Properties.Value;
         P : Properties.Manager with Unreferenced;
      begin
         P := Util.Properties.To_Manager (V);
         T.Fail ("No exception raised by To_Manager");

      exception
         when Util.Beans.Objects.Conversion_Error =>
            null;
      end;
   end Test_Save_Properties;

   procedure Test_Remove_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      begin
         Props.Remove ("missing");
         T.Fail ("Remove should raise exception");

      exception
         when NO_PROPERTY =>
            null;
      end;

      begin
         Props.Remove (+("missing"));
         T.Fail ("Remove should raise exception");

      exception
         when NO_PROPERTY =>
            null;
      end;

      Props.Set ("a", "b");
      T.Assert (Props.Exists ("a"), "Property not inserted");

      Props.Remove ("a");
      T.Assert (not Props.Exists ("a"), "Property not removed");

      Props.Set ("a", +("b"));
      T.Assert (Props.Exists ("a"), "Property not inserted");

      Props.Remove (+("a"));
      T.Assert (not Props.Exists ("a"), "Property not removed");
   end Test_Remove_Property;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Properties.Set",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Exists",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Remove",
                       Test_Remove_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get (NO_PROPERTY)",
                       Test_Missing_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Get",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Set",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties",
                       Test_Load_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties (INI)",
                       Test_Load_Ini_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Strip_Properties",
                       Test_Load_Strip_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Copy",
                       Test_Copy_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign",
                       Test_Set_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign+Remove",
                       Test_Remove_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Save_Properties",
                       Test_Save_Properties'Access);
   end Add_Tests;

end Util.Properties.Tests;

Add more test on Copy procedure

Add more test on Copy procedure