-----------------------------------------------------------------------
--  gen-generator -- Code Generator
--  Copyright (C) 2009, 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 Ada.Text_IO;
with Ada.Command_Line;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with Ada.Containers.Hashed_Maps;

with Util.Beans.Objects;
with Util.Properties;

with ASF.Applications.Main;
with ASF.Contexts.Faces;
with ASF.Servlets;

with Gen.Model.Packages;
with Gen.Model.Projects;
with Gen.Artifacts.Hibernate;
with Gen.Artifacts.Query;
with Gen.Artifacts.Mappings;
with Gen.Artifacts.Distribs;
with Gen.Artifacts.XMI;
package Gen.Generator is

   --  A fatal error that prevents the generator to proceed has occurred.
   Fatal_Error : exception;

   G_URI : constant String := "http://code.google.com/p/ada-ado/generator";

   type Package_Type is (PACKAGE_MODEL, PACKAGE_FORMS);

   type Mapping_File is record
      Path   : Ada.Strings.Unbounded.Unbounded_String;
      Output : Ada.Text_IO.File_Type;
   end record;

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with private;

   --  Initialize the generator
   procedure Initialize (H : in out Handler;
                         Config_Dir : in Ada.Strings.Unbounded.Unbounded_String;
                         Debug : in Boolean);

   --  Get the configuration properties.
   function Get_Properties (H : in Handler) return Util.Properties.Manager;

   --  Report an error and set the exit status accordingly
   procedure Error (H : in out Handler;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "");

   --  Report an info message.
   procedure Info (H : in out Handler;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   --  Read the XML package file
   procedure Read_Package (H    : in out Handler;
                           File : in String);

   --  Read the model mapping types and initialize the hibernate artifact.
   procedure Read_Mappings (H    : in out Handler);

   --  Read the XML model file
   procedure Read_Model (H      : in out Handler;
                         File   : in String;
                         Silent : in Boolean);

   --  Read the model and query files stored in the application directory db.
   procedure Read_Models (H : in out Handler;
                          Dirname : in String);

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (H         : in out Handler;
                           File      : in String;
                           Recursive : in Boolean := False);

   --  Prepare the model by checking, verifying and initializing it after it is completely known.
   procedure Prepare (H : in out Handler);

   --  Finish the generation.  Some artifacts could generate other files that take into
   --  account files generated previously.
   procedure Finish (H : in out Handler);

   --  Tell the generator to activate the generation of the given template name.
   --  The name is a property name that must be defined in generator.properties to
   --  indicate the template file.  Several artifacts can trigger the generation
   --  of a given template.  The template is generated only once.
   procedure Add_Generation (H    : in out Handler;
                             Name : in String;
                             Mode : in Gen.Artifacts.Iteration_Mode;
                             Mapping : in String);

   --  Enable the generation of the Ada package given by the name.  By default all the Ada
   --  packages found in the model are generated.  When called, this enables the generation
   --  only for the Ada packages registered here.
   procedure Enable_Package_Generation (H    : in out Handler;
                                        Name : in String);

   --  Save the content generated by the template generator.
   procedure Save_Content (H       : in out Handler;
                           File    : in String;
                           Content : in Ada.Strings.Unbounded.Unbounded_String);

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       Mode  : in Gen.Artifacts.Iteration_Mode;
                       File  : in String;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       File  : in String;
                       Model : in Gen.Model.Definition_Access;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate all the code for the templates activated through Add_Generation.
   procedure Generate_All (H    : in out Handler);

   --  Generate all the code generation files stored in the directory
   procedure Generate_All (H    : in out Handler;
                           Mode : in Gen.Artifacts.Iteration_Mode;
                           Name : in String);

   --  Set the directory where template files are stored.
   procedure Set_Template_Directory (H    : in out Handler;
                                     Path : in Ada.Strings.Unbounded.Unbounded_String);

   --  Set the directory where results files are generated.
   procedure Set_Result_Directory (H    : in out Handler;
                                   Path : in String);

   --  Get the result directory path.
   function Get_Result_Directory (H : in Handler) return String;

   --  Get the project plugin directory path.
   function Get_Plugin_Directory (H : in Handler) return String;

   --  Get the config directory path.
   function Get_Config_Directory (H : in Handler) return String;

   --  Get the dynamo installation directory path.
   function Get_Install_Directory (H : in Handler) return String;

   --  Return the search directories that the AWA application can use to find files.
   --  The search directories is built by using the project dependencies.
   function Get_Search_Directories (H : in Handler) return String;

   --  Get the exit status
   --  Returns 0 if the generation was successful
   --  Returns 1 if there was a generation error
   function Get_Status (H : in Handler) return Ada.Command_Line.Exit_Status;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Set the force-save file mode.  When False, if the generated file exists already,
   --  an error message is reported.
   procedure Set_Force_Save (H  : in out Handler;
                             To : in Boolean);

   --  Set the project name.
   procedure Set_Project_Name (H    : in out Handler;
                               Name : in String);

   --  Get the project name.
   function Get_Project_Name (H : in Handler) return String;

   --  Set the project property.
   procedure Set_Project_Property (H     : in out Handler;
                                   Name  : in String;
                                   Value : in String);

   --  Get the project property identified by the given name.  If the project property
   --  does not exist, returns the default value.  Project properties are loaded
   --  by Read_Project.
   function Get_Project_Property (H       : in Handler;
                                  Name    : in String;
                                  Default : in String := "") return String;

   --  Save the project description and parameters.
   procedure Save_Project (H : in out Handler);

   --  Get the path of the last generated file.
   function Get_Generated_File (H : in Handler) return String;

   --  Update the project model through the Process procedure.
   procedure Update_Project (H : in out Handler;
                             Process : not null access
                               procedure (P : in out Model.Projects.Root_Project_Definition));

   --  Scan the dynamo directories and execute the Process procedure with the
   --  directory path.
   procedure Scan_Directories (H : in Handler;
                               Process : not null access
                                 procedure (Dir : in String));

private

   use Ada.Strings.Unbounded;
   use Gen.Artifacts;

   type Template_Context is record
      Mode    : Gen.Artifacts.Iteration_Mode;
      Mapping : Unbounded_String;
   end record;

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

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with record
      Conf       : ASF.Applications.Config;

      --  Config directory.
      Config_Dir : Ada.Strings.Unbounded.Unbounded_String;

      --  Output base directory.
      Output_Dir : Ada.Strings.Unbounded.Unbounded_String;

      Model  : aliased Gen.Model.Packages.Model_Definition;
      Status : Ada.Command_Line.Exit_Status := 0;

      --  The file that must be saved (the file attribute in <f:view>.
      File     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be saved at each generation or only once.
      --  This is the mode attribute in <f:view>.
      Mode     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be ignored after the generation.
      --  This is the ignore attribute in <f:view>.  It is intended to be used for the package
      --  body generation to skip that in some cases when it turns out there is no operation.
      Ignore   : access Util.Beans.Objects.Object;

      --  Whether the AdaMappings.xml file was loaded or not.
      Type_Mapping_Loaded : Boolean := False;

      --  The root project document.
      Project : aliased Gen.Model.Projects.Root_Project_Definition;

      --  Hibernate XML artifact
      Hibernate : Gen.Artifacts.Hibernate.Artifact;

      --  Query generation artifact.
      Query     : Gen.Artifacts.Query.Artifact;

      --  Type mapping artifact.
      Mappings  : Gen.Artifacts.Mappings.Artifact;

      --  The distribution artifact.
      Distrib   : Gen.Artifacts.Distribs.Artifact;

      --  Ada generation from UML-XMI models.
      XMI       : Gen.Artifacts.XMI.Artifact;

      --  The list of templates that must be generated.
      Templates : Template_Map.Map;

      --  Force the saving of a generated file, even if a file already exist.
      Force_Save : Boolean := True;

      --  A fake servlet for template evaluation.
      Servlet    : ASF.Servlets.Servlet_Access;
   end record;

   --  Execute the lifecycle phases on the faces context.
   overriding
   procedure Execute_Lifecycle (App     : in Handler;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end Gen.Generator;

-----------------------------------------------------------------------
--  gen-generator -- Code Generator
--  Copyright (C) 2009, 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 Ada.Text_IO;
with Ada.Command_Line;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with Ada.Containers.Hashed_Maps;

with Util.Beans.Objects;
with Util.Properties;

with ASF.Applications.Main;
with ASF.Contexts.Faces;
with ASF.Servlets;

with Gen.Model.Packages;
with Gen.Model.Projects;
with Gen.Artifacts.Hibernate;
with Gen.Artifacts.Query;
with Gen.Artifacts.Mappings;
with Gen.Artifacts.Distribs;
with Gen.Artifacts.XMI;
with Gen.Artifacts.Yaml;
package Gen.Generator is

   --  A fatal error that prevents the generator to proceed has occurred.
   Fatal_Error : exception;

   G_URI : constant String := "http://code.google.com/p/ada-ado/generator";

   type Package_Type is (PACKAGE_MODEL, PACKAGE_FORMS);

   type Mapping_File is record
      Path   : Ada.Strings.Unbounded.Unbounded_String;
      Output : Ada.Text_IO.File_Type;
   end record;

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with private;

   --  Initialize the generator
   procedure Initialize (H : in out Handler;
                         Config_Dir : in Ada.Strings.Unbounded.Unbounded_String;
                         Debug : in Boolean);

   --  Get the configuration properties.
   function Get_Properties (H : in Handler) return Util.Properties.Manager;

   --  Report an error and set the exit status accordingly
   procedure Error (H : in out Handler;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "");

   --  Report an info message.
   procedure Info (H : in out Handler;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   --  Read the XML package file
   procedure Read_Package (H    : in out Handler;
                           File : in String);

   --  Read the model mapping types and initialize the hibernate artifact.
   procedure Read_Mappings (H    : in out Handler);

   --  Read the XML model file
   procedure Read_Model (H      : in out Handler;
                         File   : in String;
                         Silent : in Boolean);

   --  Read the model and query files stored in the application directory db.
   procedure Read_Models (H : in out Handler;
                          Dirname : in String);

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (H         : in out Handler;
                           File      : in String;
                           Recursive : in Boolean := False);

   --  Prepare the model by checking, verifying and initializing it after it is completely known.
   procedure Prepare (H : in out Handler);

   --  Finish the generation.  Some artifacts could generate other files that take into
   --  account files generated previously.
   procedure Finish (H : in out Handler);

   --  Tell the generator to activate the generation of the given template name.
   --  The name is a property name that must be defined in generator.properties to
   --  indicate the template file.  Several artifacts can trigger the generation
   --  of a given template.  The template is generated only once.
   procedure Add_Generation (H    : in out Handler;
                             Name : in String;
                             Mode : in Gen.Artifacts.Iteration_Mode;
                             Mapping : in String);

   --  Enable the generation of the Ada package given by the name.  By default all the Ada
   --  packages found in the model are generated.  When called, this enables the generation
   --  only for the Ada packages registered here.
   procedure Enable_Package_Generation (H    : in out Handler;
                                        Name : in String);

   --  Save the content generated by the template generator.
   procedure Save_Content (H       : in out Handler;
                           File    : in String;
                           Content : in Ada.Strings.Unbounded.Unbounded_String);

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       Mode  : in Gen.Artifacts.Iteration_Mode;
                       File  : in String;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       File  : in String;
                       Model : in Gen.Model.Definition_Access;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate all the code for the templates activated through Add_Generation.
   procedure Generate_All (H    : in out Handler);

   --  Generate all the code generation files stored in the directory
   procedure Generate_All (H    : in out Handler;
                           Mode : in Gen.Artifacts.Iteration_Mode;
                           Name : in String);

   --  Set the directory where template files are stored.
   procedure Set_Template_Directory (H    : in out Handler;
                                     Path : in Ada.Strings.Unbounded.Unbounded_String);

   --  Set the directory where results files are generated.
   procedure Set_Result_Directory (H    : in out Handler;
                                   Path : in String);

   --  Get the result directory path.
   function Get_Result_Directory (H : in Handler) return String;

   --  Get the project plugin directory path.
   function Get_Plugin_Directory (H : in Handler) return String;

   --  Get the config directory path.
   function Get_Config_Directory (H : in Handler) return String;

   --  Get the dynamo installation directory path.
   function Get_Install_Directory (H : in Handler) return String;

   --  Return the search directories that the AWA application can use to find files.
   --  The search directories is built by using the project dependencies.
   function Get_Search_Directories (H : in Handler) return String;

   --  Get the exit status
   --  Returns 0 if the generation was successful
   --  Returns 1 if there was a generation error
   function Get_Status (H : in Handler) return Ada.Command_Line.Exit_Status;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Set the force-save file mode.  When False, if the generated file exists already,
   --  an error message is reported.
   procedure Set_Force_Save (H  : in out Handler;
                             To : in Boolean);

   --  Set the project name.
   procedure Set_Project_Name (H    : in out Handler;
                               Name : in String);

   --  Get the project name.
   function Get_Project_Name (H : in Handler) return String;

   --  Set the project property.
   procedure Set_Project_Property (H     : in out Handler;
                                   Name  : in String;
                                   Value : in String);

   --  Get the project property identified by the given name.  If the project property
   --  does not exist, returns the default value.  Project properties are loaded
   --  by Read_Project.
   function Get_Project_Property (H       : in Handler;
                                  Name    : in String;
                                  Default : in String := "") return String;

   --  Save the project description and parameters.
   procedure Save_Project (H : in out Handler);

   --  Get the path of the last generated file.
   function Get_Generated_File (H : in Handler) return String;

   --  Update the project model through the Process procedure.
   procedure Update_Project (H : in out Handler;
                             Process : not null access
                               procedure (P : in out Model.Projects.Root_Project_Definition));

   --  Scan the dynamo directories and execute the Process procedure with the
   --  directory path.
   procedure Scan_Directories (H : in Handler;
                               Process : not null access
                                 procedure (Dir : in String));

private

   use Ada.Strings.Unbounded;
   use Gen.Artifacts;

   type Template_Context is record
      Mode    : Gen.Artifacts.Iteration_Mode;
      Mapping : Unbounded_String;
   end record;

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

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with record
      Conf       : ASF.Applications.Config;

      --  Config directory.
      Config_Dir : Ada.Strings.Unbounded.Unbounded_String;

      --  Output base directory.
      Output_Dir : Ada.Strings.Unbounded.Unbounded_String;

      Model  : aliased Gen.Model.Packages.Model_Definition;
      Status : Ada.Command_Line.Exit_Status := 0;

      --  The file that must be saved (the file attribute in <f:view>.
      File     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be saved at each generation or only once.
      --  This is the mode attribute in <f:view>.
      Mode     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be ignored after the generation.
      --  This is the ignore attribute in <f:view>.  It is intended to be used for the package
      --  body generation to skip that in some cases when it turns out there is no operation.
      Ignore   : access Util.Beans.Objects.Object;

      --  Whether the AdaMappings.xml file was loaded or not.
      Type_Mapping_Loaded : Boolean := False;

      --  The root project document.
      Project : aliased Gen.Model.Projects.Root_Project_Definition;

      --  Hibernate XML artifact
      Hibernate : Gen.Artifacts.Hibernate.Artifact;

      --  Query generation artifact.
      Query     : Gen.Artifacts.Query.Artifact;

      --  Type mapping artifact.
      Mappings  : Gen.Artifacts.Mappings.Artifact;

      --  The distribution artifact.
      Distrib   : Gen.Artifacts.Distribs.Artifact;

      --  Ada generation from UML-XMI models.
      XMI       : Gen.Artifacts.XMI.Artifact;

      --  Yaml model files support.
      Yaml      : Gen.Artifacts.Yaml.Artifact;

      --  The list of templates that must be generated.
      Templates : Template_Map.Map;

      --  Force the saving of a generated file, even if a file already exist.
      Force_Save : Boolean := True;

      --  A fake servlet for template evaluation.
      Servlet    : ASF.Servlets.Servlet_Access;
   end record;

   --  Execute the lifecycle phases on the faces context.
   overriding
   procedure Execute_Lifecycle (App     : in Handler;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end Gen.Generator;

Add the YAML artifact

Add the YAML artifact


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

with Sax.Readers;        use Sax.Readers;
with Ada.Text_IO;

with Ada.Exceptions;
with Ada.Command_Line;

with Gen.Generator;
procedure DBMapper is
   use Ada;

   use Ada.Command_Line;

   Generator : Gen.Generator.Handler;

   Release : constant String
     := "ADO Generator 0.2, Stephane Carrez";

   Copyright : constant String
     := "Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.";

   -----------------
   -- Output_File --
   -----------------
   --------------------------------------------------
   --  Usage
   --------------------------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line (Release);
      Put_Line (Copyright);

      New_Line;
      Put ("Usage: ");
      Put (Command_Name);
      Put_Line (" [-v] [-o directory] [-t templates] model.xml");
      Put_Line ("where:");
      Put_Line ("   -v           Verbose");
      Put_Line ("   -q           Query mode");
      Put_Line ("   -o directory Directory where the Ada mapping files are generated");
      Put_Line ("   -t templates Directory where the Ada templates are defined");
      New_Line;
      Put_Line ("   -h           Requests this info.");
      New_Line;
   end Usage;

begin
   --  Parse the command line
   loop
      case Getopt ("o: t:") is
         when ASCII.Nul => exit;

         when 'o' =>
            Gen.Generator.Set_Result_Directory (Generator, Parameter & "/");

         when 't' =>
            Gen.Generator.Set_Template_Directory (Generator, Parameter & "/");

         when others =>
            null;
      end case;
   end loop;

   declare
      Model_File : constant String := Get_Argument;
   begin
      if Model_File'Length = 0 then
         Usage;
         Set_Exit_Status (2);
         return;
      end if;
      Gen.Generator.Initialize (Generator);
      Gen.Generator.Read_Model (Generator, Model_File);
      Gen.Generator.Generate_All (Generator, Gen.Generator.ITERATION_PACKAGE, "model");
      Gen.Generator.Generate_All (Generator, Gen.Generator.ITERATION_TABLE, "sql");

      Ada.Command_Line.Set_Exit_Status (Gen.Generator.Get_Status (Generator));
   end;

exception
   when E : XML_Fatal_Error =>
      Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
end DBMapper;

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

with Sax.Readers;        use Sax.Readers;
with Ada.Text_IO;

with Ada.Exceptions;
with Ada.Command_Line;

with Gen.Generator;
procedure DBMapper is
   use Ada;

   use Ada.Command_Line;

   Generator : Gen.Generator.Handler;

   Release : constant String
     := "ADO Generator 0.2, Stephane Carrez";

   Copyright : constant String
     := "Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.";

   -----------------
   -- Output_File --
   -----------------
   --------------------------------------------------
   --  Usage
   --------------------------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line (Release);
      Put_Line (Copyright);

      New_Line;
      Put ("Usage: ");
      Put (Command_Name);
      Put_Line (" [-v] [-o directory] [-t templates] model.xml");
      Put_Line ("where:");
      Put_Line ("   -v           Verbose");
      Put_Line ("   -q           Query mode");
      Put_Line ("   -o directory Directory where the Ada mapping files are generated");
      Put_Line ("   -t templates Directory where the Ada templates are defined");
      New_Line;
      Put_Line ("   -h           Requests this info.");
      New_Line;
   end Usage;

begin
   --  Parse the command line
   loop
      case Getopt ("o: t:") is
         when ASCII.Nul => exit;

         when 'o' =>
            Gen.Generator.Set_Result_Directory (Generator, Parameter & "/");

         when 't' =>
            Gen.Generator.Set_Template_Directory (Generator, Parameter & "/");

         when others =>
            null;
      end case;
   end loop;

   Gen.Generator.Initialize (Generator);
   loop
      declare
         Model_File : constant String := Get_Argument;
      begin
         exit when Model_File'Length = 0;
--           if Model_File'Length = 0 then
--              Usage;
--              Set_Exit_Status (2);
--              return;
--           end if;
         Gen.Generator.Read_Model (Generator, Model_File);
      end;
   end loop;

   Gen.Generator.Generate_All (Generator, Gen.Generator.ITERATION_PACKAGE, "model");
   Gen.Generator.Generate_All (Generator, Gen.Generator.ITERATION_TABLE, "sql");

   Ada.Command_Line.Set_Exit_Status (Gen.Generator.Get_Status (Generator));

exception
   when E : XML_Fatal_Error =>
      Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
end DBMapper;

Allow to read several model files and generate all the necessary packages.


-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

name = "Archive.Today"
type = "archive"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    scrape(ctx, buildurl(domain))
end

function buildurl(domain)
    return "http://archive.is/*." .. domain
end

-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

name = "ArchiveToday"
type = "archive"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    scrape(ctx, buildurl(domain))
end

function buildurl(domain)
    return "http://archive.is/*." .. domain
end

Rename Archive.Today to ArchiveToday

Rename Archive.Today to ArchiveToday


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

package body Util.Http.Mockups is

   -----------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Message : in Mockup_Message;
                             Name    : in String) return Boolean is
   begin
      return Message.Headers.Contains (Name);
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   overriding
   function Get_Header (Message : in Mockup_Message;
                        Name    : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Message.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Message  : in out Mockup_Message;
                         Name     : in String;
                         Value    : in String) is
   begin
      Message.Headers.Include (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Message : in out Mockup_Message;
                         Name    : in String;
                         Value   : in String) is

      Pos : constant Util.Strings.Maps.Cursor := Message.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         declare
            Header : constant String := Util.Strings.Maps.Element (Pos);
         begin
            Message.Headers.Replace_Element (Pos, Header & ASCII.CR & ASCII.LF & Value);
         end;
      else
         Message.Headers.Include (Name, Value);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   overriding
   procedure Iterate_Headers (Message : in Mockup_Message;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Iter : Util.Strings.Maps.Cursor := Message.Headers.First;
   begin
      while Util.Strings.Maps.Has_Element (Iter) loop
         Util.Strings.Maps.Query_Element (Iter, Process);
         Util.Strings.Maps.Next (Iter);
      end loop;
   end Iterate_Headers;

   --  -------------
   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Mockup_Response) return String is
   begin
      return Util.Strings.Builders.To_Array (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Mockup_Response) return Util.Blobs.Blob_Ref is
      use Ada.Streams;

      Result : constant Util.Blobs.Blob_Ref
        := Util.Blobs.Create_Blob (Size => Util.Strings.Builders.Length (Reply.Content));
      Offset : Stream_Element_Offset := 1;

      procedure Append (Content : in String) is
         C : Stream_Element_Array (1 .. Stream_Element_Offset (Content'Length));
         for C'Address use Content'Address;
      begin
         Result.Value.Data (Offset .. Offset + C'Length - 1) := C;
         Offset := Offset + C'Length;
      end Append;

      procedure Copy is new Util.Strings.Builders.Inline_Iterate (Append);
   begin
      Copy (Reply.Content);
      return Result;
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Mockup_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

   --  ------------------------------
   --  Set the response status code.
   --  ------------------------------
   procedure Set_Status (Reply  : in out Mockup_Response;
                         Status : in Natural) is
   begin
      Reply.Status := Status;
   end Set_Status;

   --  ------------------------------
   --  Set the response body.
   --  ------------------------------
   procedure Set_Body (Reply   : in out Mockup_Response;
                       Content : in String) is
   begin
      Util.Strings.Builders.Clear (Reply.Content);
      Util.Strings.Builders.Append (Reply.Content, Content);
   end Set_Body;

   --  ------------------------------
   --  Append the content to the response body.
   --  ------------------------------
   procedure Append_Body (Reply   : in out Mockup_Response;
                          Content : in String) is
   begin
      Util.Strings.Builders.Append (Reply.Content, Content);
   end Append_Body;

end Util.Http.Mockups;

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

package body Util.Http.Mockups is

   -----------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Message : in Mockup_Message;
                             Name    : in String) return Boolean is
   begin
      return Message.Headers.Contains (Name);
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   overriding
   function Get_Header (Message : in Mockup_Message;
                        Name    : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Message.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Message  : in out Mockup_Message;
                         Name     : in String;
                         Value    : in String) is
   begin
      Message.Headers.Include (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Message : in out Mockup_Message;
                         Name    : in String;
                         Value   : in String) is

      Pos : constant Util.Strings.Maps.Cursor := Message.Headers.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         declare
            Header : constant String := Util.Strings.Maps.Element (Pos);
         begin
            Message.Headers.Replace_Element (Pos, Header & ASCII.CR & ASCII.LF & Value);
         end;
      else
         Message.Headers.Include (Name, Value);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   overriding
   procedure Iterate_Headers (Message : in Mockup_Message;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Iter : Util.Strings.Maps.Cursor := Message.Headers.First;
   begin
      while Util.Strings.Maps.Has_Element (Iter) loop
         Util.Strings.Maps.Query_Element (Iter, Process);
         Util.Strings.Maps.Next (Iter);
      end loop;
   end Iterate_Headers;

   --  -------------
   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Mockup_Response) return String is
   begin
      return Util.Strings.Builders.To_Array (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Mockup_Response) return Util.Blobs.Blob_Ref is
      use Ada.Streams;
      procedure Append (Content : in String);

      Result : constant Util.Blobs.Blob_Ref
        := Util.Blobs.Create_Blob (Size => Util.Strings.Builders.Length (Reply.Content));
      Offset : Stream_Element_Offset := 1;

      procedure Append (Content : in String) is
         C : Stream_Element_Array (1 .. Stream_Element_Offset (Content'Length));
         for C'Address use Content'Address;
      begin
         Result.Value.Data (Offset .. Offset + C'Length - 1) := C;
         Offset := Offset + C'Length;
      end Append;

      procedure Copy is new Util.Strings.Builders.Inline_Iterate (Append);
   begin
      Copy (Reply.Content);
      return Result;
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Mockup_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

   --  ------------------------------
   --  Set the response status code.
   --  ------------------------------
   procedure Set_Status (Reply  : in out Mockup_Response;
                         Status : in Natural) is
   begin
      Reply.Status := Status;
   end Set_Status;

   --  ------------------------------
   --  Set the response body.
   --  ------------------------------
   procedure Set_Body (Reply   : in out Mockup_Response;
                       Content : in String) is
   begin
      Util.Strings.Builders.Clear (Reply.Content);
      Util.Strings.Builders.Append (Reply.Content, Content);
   end Set_Body;

   --  ------------------------------
   --  Append the content to the response body.
   --  ------------------------------
   procedure Append_Body (Reply   : in out Mockup_Response;
                          Content : in String) is
   begin
      Util.Strings.Builders.Append (Reply.Content, Content);
   end Append_Body;

end Util.Http.Mockups;

Fix compilation warning

Fix compilation warning


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

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

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

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   pragma Preelaborate;

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

Make the package Preelaborate

Make the package Preelaborate


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

with Ada.IO_Exceptions;

package body Util.Streams.Raw is

   use Util.Systems.Os;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      use type Util.Systems.Types.off_t;

      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

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

with Ada.IO_Exceptions;

package body Util.Streams.Raw is

   use Util.Systems.Os;
   use type Util.Systems.Types.File_Type;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      --  use type Util.Systems.Types.off_t;

      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

Use Util.Systems.Types.File_Type type

Use Util.Systems.Types.File_Type type


-----------------------------------------------------------------------
--  ADO Objects Tests -- Tests for ADO.Objects
--  Copyright (C) 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.Test_Caller;
with ADO.Sessions;
with Regtests.Simple.Model;
with Regtests.Comments;
with Regtests.Statements.Model;
package body ADO.Objects.Tests is

   use Util.Tests;
   use type Ada.Containers.Hash_Type;

   --  Test the Set_xxx and Get_xxx operation on various simple times.
   generic
      Name : String;
      type Element_Type (<>) is private;
      with function "=" (Left, Right : in Element_Type) return Boolean is <>;
      with procedure Set_Value (Item : in out Regtests.Statements.Model.Nullable_Table_Ref;
                                Val  : in Element_Type);
      with function Get_Value (Item : in Regtests.Statements.Model.Nullable_Table_Ref)
                               return Element_Type;
      Val1 : Element_Type;
      Val2 : Element_Type;
   procedure Test_Op (T : in out Test);

   procedure Test_Op (T : in out Test) is
      Item1 : Regtests.Statements.Model.Nullable_Table_Ref;
      Item2 : Regtests.Statements.Model.Nullable_Table_Ref;
      Item3 : Regtests.Statements.Model.Nullable_Table_Ref;
      DB    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
   begin
      Set_Value (Item1, Val1);
      Item1.Save (DB);
      T.Assert (Item1.Is_Inserted, Name & " item is created");
      --  Util.Tests.Assert_Equals (T, T'Image (Val), T'Image (

      --  Load in a second item and check the value.
      Item2.Load (DB, Item1.Get_Id);
      T.Assert (Item2.Get_Id = Item1.Get_Id, Name & " item2 cannot be loaded");
      --  T.Assert (Get_Value (Item2) = Val1, Name & " invalid value loaded in item2");

      --  Change the item in database.
      Set_Value (Item2, Val2);
      Item2.Save (DB);
      T.Assert (Get_Value (Item2) = Val2, Name & " invalid value loaded in item2");

      --  Load again and compare to check the update.
      Item3.Load (DB, Item2.Get_Id);
      T.Assert (Get_Value (Item3) = Val2, Name & " invalid value loaded in item3");
   end Test_Op;

   procedure Test_Object_Nullable_Integer is
     new Test_Op ("Nullable_Integer",
                  Nullable_Integer, "=",
                  Regtests.Statements.Model.Set_Int_Value,
                  Regtests.Statements.Model.Get_Int_Value,
                  Nullable_Integer '(Value => 123, Is_Null => False),
                  Nullable_Integer '(Value => 0, Is_Null => True));

   procedure Test_Object_Nullable_Entity_Type is
     new Test_Op ("Nullable_Entity_Type",
                  Nullable_Entity_Type, "=",
                  Regtests.Statements.Model.Set_Entity_Value,
                  Regtests.Statements.Model.Get_Entity_Value,
                  Nullable_Entity_Type '(Value => 456, Is_Null => False),
                  Nullable_Entity_Type '(Value => 0, Is_Null => True));

   procedure Test_Object_Nullable_Time is
     new Test_Op ("Nullable_Time",
                  Nullable_Time, "=",
                  Regtests.Statements.Model.Set_Time_Value,
                  Regtests.Statements.Model.Get_Time_Value,
                  Nullable_Time '(Value => 456, Is_Null => False),
                  Nullable_Time '(Value => <>, Is_Null => True));

   function Get_Allocate_Key (N : Identifier) return Object_Key;

   function Get_Allocate_Key (N : Identifier) return Object_Key is
      Result : Object_Key (Of_Type  => KEY_INTEGER,
                           Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
   begin
      Set_Value (Result, N);
      return Result;
   end Get_Allocate_Key;

   --  ------------------------------
   --  Various tests on Hash and key comparison
   --  ------------------------------
   procedure Test_Key (T : in out Test) is
      K1 : constant Object_Key := Get_Allocate_Key (1);
      K2 : Object_Key (Of_Type  => KEY_STRING,
                       Of_Class => Regtests.Simple.Model.USER_TABLE);
      K3 : Object_Key := K1;
      K4 : Object_Key (Of_Type  => KEY_INTEGER,
                       Of_Class => Regtests.Simple.Model.USER_TABLE);
   begin
      T.Assert (not (K1 = K2), "Key on different tables must be different");
      T.Assert (not (K2 = K4), "Key with different type must be different");
      T.Assert (K1 = K3, "Keys are identical");
      T.Assert (Equivalent_Elements (K1, K3), "Keys are identical");
      T.Assert (Equivalent_Elements (K3, K1), "Keys are identical");

      T.Assert (Hash (K1) = Hash (K3), "Hash of identical keys should be identical");

      Set_Value (K3, 2);
      T.Assert (not (K1 = K3), "Keys should be different");
      T.Assert (Hash (K1) /= Hash (K3), "Hash should be different");
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");

      Set_Value (K4, 1);
      T.Assert (Hash (K1) /= Hash (K4),
               "Hash on key with same value and different tables should be different");
      T.Assert (not (K4 = K1), "Key on different tables should be different");

      Set_Value (K2, 1);
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");
   end Test_Key;

   --  ------------------------------
   --  Check:
   --    Object_Ref := (reference counting)
   --    Object_Ref.Copy
   --    Object_Ref.Get_xxx generated method
   --    Object_Ref.Set_xxx generated method
   --    Object_Ref.=
   --  ------------------------------
   procedure Test_Object_Ref (T : in out Test) is
      use type Regtests.Simple.Model.User_Ref;
      Obj1     : Regtests.Simple.Model.User_Ref;
      Null_Obj : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Obj1 = Null_Obj, "Two null objects are identical");
      for I in 1 .. 10 loop
         Obj1.Set_Name ("User name");
         T.Assert (Obj1.Get_Name = "User name", "User_Ref.Set_Name invalid result");

         T.Assert (Obj1 /= Null_Obj, "Object is not identical as the null object");
         declare
            Obj2 : constant Regtests.Simple.Model.User_Ref := Obj1;
            Obj3 : Regtests.Simple.Model.User_Ref;
         begin
            Obj1.Copy (Obj3);
            Obj3.Set_Id (2);
            --  Check the copy
            T.Assert (Obj2.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            T.Assert (Obj3 /= Obj1, "Object_Ref.'=' invalid comparison after copy");

            --  Change original, make sure it's the same of Obj2.
            Obj1.Set_Name ("Second name");
            T.Assert (Obj2.Get_Name = "Second name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            --  The copy is not modified
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
         end;
      end loop;
   end Test_Object_Ref;

   --  ------------------------------
   --  Test creation of an object with lazy loading.
   --  ------------------------------
   procedure Test_Create_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
      Cmt  : Regtests.Comments.Comment_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (not U2.Get_Name.Is_Null,
                   "Cannot load created object");
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (U2.Get_Name.Value),
                        "Cannot load created object");
         Assert_Equals (T, Integer (0), Integer (U2.Get_Value), "Invalid load");
         T.Assert (User.Get_Key = U2.Get_Key, "Invalid key after load");
      end;

      --  Create a comment for the user.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         Cmt.Set_Message (Ada.Strings.Unbounded.To_Unbounded_String ("A comment from Joe"));
         Cmt.Set_User (User);
         Cmt.Set_Entity_Id (2);
         Cmt.Set_Entity_Type (1);
         --  Cmt.Set_Date (ADO.DEFAULT_TIME);
         Cmt.Set_Date (Ada.Calendar.Clock);
         Cmt.Save (S);
         S.Commit;
      end;

      --  Load that comment.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         C2 : Regtests.Comments.Comment_Ref;
      begin
         T.Assert (not C2.Is_Loaded, "Object is not loaded");
         C2.Load (S, Cmt.Get_Id);
         T.Assert (not C2.Is_Null, "Loading of object failed");
         T.Assert (C2.Is_Loaded, "Object is loaded");
         T.Assert (Cmt.Get_Key = C2.Get_Key, "Invalid key after load");
         T.Assert_Equals ("A comment from Joe", Ada.Strings.Unbounded.To_String (C2.Get_Message),
                          "Invalid message");

         T.Assert (not C2.Get_User.Is_Null, "User associated with the comment should not be null");
--           T.Assert (not C2.Get_Entity_Type.Is_Null, "Entity type was not set");

         --  Check that we can access the user name (lazy load)
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (C2.Get_User.Get_Name.Value),
                        "Cannot load created object");
      end;
   end Test_Create_Object;

   --  ------------------------------
   --  Test creation and deletion of an object record
   --  ------------------------------
   procedure Test_Delete_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe (delete)");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it and delete it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);

         S.Begin_Transaction;
         U2.Delete (S);
         S.Commit;
      end;

      --  Try to load the deleted object.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (False, "Load of a deleted object should raise NOT_FOUND");

      exception
         when ADO.Objects.NOT_FOUND =>
            null;
      end;
   end Test_Delete_Object;

   --  ------------------------------
   --  Test Is_Inserted and Is_Null
   --  ------------------------------
   procedure Test_Is_Inserted (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (not User.Is_Inserted, "A null object should not be marked as INSERTED");
      T.Assert (User.Is_Null, "A null object should be marked as NULL");

      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("John");
         T.Assert (not User.Is_Null, "User should not be NULL");
         T.Assert (not User.Is_Inserted, "User was not saved and not yet inserted in database");

         User.Set_Value (1);
         User.Save (S);
         S.Commit;
         T.Assert (User.Is_Inserted, "After a save operation, the user should be marked INSERTED");
         T.Assert (not User.Is_Null, "User should not be NULL");
      end;

      declare
         S    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         John : Regtests.Simple.Model.User_Ref;
      begin
         John.Load (S, User.Get_Id);
         T.Assert (John.Is_Inserted, "After a load, the object should be marked INSERTED");
         T.Assert (not John.Is_Null, "After a load, the object should not be NULL");
      end;
   end Test_Is_Inserted;

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

   --  ------------------------------
   --  Add the tests in the test suite
   --  ------------------------------
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Objects.Hash", Test_Key'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Get/Set", Test_Object_Ref'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Create", Test_Create_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Delete", Test_Delete_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Is_Created", Test_Is_Inserted'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Integer)",
                       Test_Object_Nullable_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Entity_Type)",
                       Test_Object_Nullable_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Time)",
                       Test_Object_Nullable_Time'Access);
   end Add_Tests;

end ADO.Objects.Tests;

-----------------------------------------------------------------------
--  ADO Objects Tests -- Tests for ADO.Objects
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018, 2019 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 ADO.Sessions;
with Regtests.Simple.Model;
with Regtests.Comments;
with Regtests.Statements.Model;
package body ADO.Objects.Tests is

   use Util.Tests;
   use type Ada.Containers.Hash_Type;

   --  Test the Set_xxx and Get_xxx operation on various simple times.
   generic
      Name : String;
      type Element_Type (<>) is private;
      with function "=" (Left, Right : in Element_Type) return Boolean is <>;
      with procedure Set_Value (Item : in out Regtests.Statements.Model.Nullable_Table_Ref;
                                Val  : in Element_Type);
      with function Get_Value (Item : in Regtests.Statements.Model.Nullable_Table_Ref)
                               return Element_Type;
      Val1 : Element_Type;
      Val2 : Element_Type;
      Val3 : Element_Type;
   procedure Test_Op (T : in out Test);

   procedure Test_Op (T : in out Test) is
      Item1 : Regtests.Statements.Model.Nullable_Table_Ref;
      Item2 : Regtests.Statements.Model.Nullable_Table_Ref;
      Item3 : Regtests.Statements.Model.Nullable_Table_Ref;
      DB    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
   begin
      Set_Value (Item1, Val1);
      Item1.Save (DB);
      T.Assert (Item1.Is_Inserted, Name & " item is created");
      --  Util.Tests.Assert_Equals (T, T'Image (Val), T'Image (

      --  Load in a second item and check the value.
      Item2.Load (DB, Item1.Get_Id);
      T.Assert (Item2.Get_Id = Item1.Get_Id, Name & " item2 cannot be loaded");
      --  T.Assert (Get_Value (Item2) = Val1, Name & " invalid value loaded in item2");

      --  Change the item in database.
      Set_Value (Item2, Val2);
      Item2.Save (DB);
      T.Assert (Get_Value (Item2) = Val2, Name & " invalid value loaded in item2");

      --  Load again and compare to check the update.
      Item3.Load (DB, Item2.Get_Id);
      T.Assert (Get_Value (Item3) = Val2, Name & " invalid value loaded in item3");

      begin
         Set_Value (Item1, Val3);
         Item1.Save (DB);
         T.Fail ("No LAZY_LOCK exception was raised.");

      exception
         when ADO.Objects.LAZY_LOCK =>
            null;
      end;

      Set_Value (Item3, Val3);
      Item3.Save (DB);
      T.Assert (Get_Value (Item3) = Val3, Name & " invalid value loaded in item3");

      Item1.Load (DB, Item1.Get_Id);
      T.Assert (Get_Value (Item1) = Val3, Name & " invalid value loaded in item3");
   end Test_Op;

   procedure Test_Object_Nullable_Integer is
     new Test_Op ("Nullable_Integer",
                  Nullable_Integer, "=",
                  Regtests.Statements.Model.Set_Int_Value,
                  Regtests.Statements.Model.Get_Int_Value,
                  Nullable_Integer '(Value => 123, Is_Null => False),
                  Nullable_Integer '(Value => 0, Is_Null => True),
                  Nullable_Integer '(Value => 231, Is_Null => False));

   procedure Test_Object_Nullable_Entity_Type is
     new Test_Op ("Nullable_Entity_Type",
                  Nullable_Entity_Type, "=",
                  Regtests.Statements.Model.Set_Entity_Value,
                  Regtests.Statements.Model.Get_Entity_Value,
                  Nullable_Entity_Type '(Value => 456, Is_Null => False),
                  Nullable_Entity_Type '(Value => 0, Is_Null => True),
                  Nullable_Entity_Type '(Value => 564, Is_Null => False));

   procedure Test_Object_Nullable_Time is
     new Test_Op ("Nullable_Time",
                  Nullable_Time, "=",
                  Regtests.Statements.Model.Set_Time_Value,
                  Regtests.Statements.Model.Get_Time_Value,
                  Nullable_Time '(Value => 45621, Is_Null => False),
                  Nullable_Time '(Value => <>, Is_Null => True),
                  Nullable_Time '(Value => 56412, Is_Null => False));

   function Get_Allocate_Key (N : Identifier) return Object_Key;

   function Get_Allocate_Key (N : Identifier) return Object_Key is
      Result : Object_Key (Of_Type  => KEY_INTEGER,
                           Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
   begin
      Set_Value (Result, N);
      return Result;
   end Get_Allocate_Key;

   --  ------------------------------
   --  Various tests on Hash and key comparison
   --  ------------------------------
   procedure Test_Key (T : in out Test) is
      K1 : constant Object_Key := Get_Allocate_Key (1);
      K2 : Object_Key (Of_Type  => KEY_STRING,
                       Of_Class => Regtests.Simple.Model.USER_TABLE);
      K3 : Object_Key := K1;
      K4 : Object_Key (Of_Type  => KEY_INTEGER,
                       Of_Class => Regtests.Simple.Model.USER_TABLE);
   begin
      T.Assert (not (K1 = K2), "Key on different tables must be different");
      T.Assert (not (K2 = K4), "Key with different type must be different");
      T.Assert (K1 = K3, "Keys are identical");
      T.Assert (Equivalent_Elements (K1, K3), "Keys are identical");
      T.Assert (Equivalent_Elements (K3, K1), "Keys are identical");

      T.Assert (Hash (K1) = Hash (K3), "Hash of identical keys should be identical");

      Set_Value (K3, 2);
      T.Assert (not (K1 = K3), "Keys should be different");
      T.Assert (Hash (K1) /= Hash (K3), "Hash should be different");
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");

      Set_Value (K4, 1);
      T.Assert (Hash (K1) /= Hash (K4),
               "Hash on key with same value and different tables should be different");
      T.Assert (not (K4 = K1), "Key on different tables should be different");

      Set_Value (K2, 1);
      T.Assert (Hash (K1) /= Hash (K2), "Hash should be different");
   end Test_Key;

   --  ------------------------------
   --  Check:
   --    Object_Ref := (reference counting)
   --    Object_Ref.Copy
   --    Object_Ref.Get_xxx generated method
   --    Object_Ref.Set_xxx generated method
   --    Object_Ref.=
   --  ------------------------------
   procedure Test_Object_Ref (T : in out Test) is
      use type Regtests.Simple.Model.User_Ref;
      Obj1     : Regtests.Simple.Model.User_Ref;
      Null_Obj : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Obj1 = Null_Obj, "Two null objects are identical");
      for I in 1 .. 10 loop
         Obj1.Set_Name ("User name");
         T.Assert (Obj1.Get_Name = "User name", "User_Ref.Set_Name invalid result");

         T.Assert (Obj1 /= Null_Obj, "Object is not identical as the null object");
         declare
            Obj2 : constant Regtests.Simple.Model.User_Ref := Obj1;
            Obj3 : Regtests.Simple.Model.User_Ref;
         begin
            Obj1.Copy (Obj3);
            Obj3.Set_Id (2);
            --  Check the copy
            T.Assert (Obj2.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            T.Assert (Obj3 /= Obj1, "Object_Ref.'=' invalid comparison after copy");

            --  Change original, make sure it's the same of Obj2.
            Obj1.Set_Name ("Second name");
            T.Assert (Obj2.Get_Name = "Second name", "Object_Ref.Copy invalid copy");
            T.Assert (Obj2 = Obj1, "Object_Ref.'=' invalid comparison after assignment");

            --  The copy is not modified
            T.Assert (Obj3.Get_Name = "User name", "Object_Ref.Copy invalid copy");
         end;
      end loop;
   end Test_Object_Ref;

   --  ------------------------------
   --  Test creation of an object with lazy loading.
   --  ------------------------------
   procedure Test_Create_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
      Cmt  : Regtests.Comments.Comment_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (not U2.Get_Name.Is_Null,
                   "Cannot load created object");
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (U2.Get_Name.Value),
                        "Cannot load created object");
         Assert_Equals (T, Integer (0), Integer (U2.Get_Value), "Invalid load");
         T.Assert (User.Get_Key = U2.Get_Key, "Invalid key after load");
      end;

      --  Create a comment for the user.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         Cmt.Set_Message (Ada.Strings.Unbounded.To_Unbounded_String ("A comment from Joe"));
         Cmt.Set_User (User);
         Cmt.Set_Entity_Id (2);
         Cmt.Set_Entity_Type (1);
         --  Cmt.Set_Date (ADO.DEFAULT_TIME);
         Cmt.Set_Date (Ada.Calendar.Clock);
         Cmt.Save (S);
         S.Commit;
      end;

      --  Load that comment.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         C2 : Regtests.Comments.Comment_Ref;
      begin
         T.Assert (not C2.Is_Loaded, "Object is not loaded");
         C2.Load (S, Cmt.Get_Id);
         T.Assert (not C2.Is_Null, "Loading of object failed");
         T.Assert (C2.Is_Loaded, "Object is loaded");
         T.Assert (Cmt.Get_Key = C2.Get_Key, "Invalid key after load");
         T.Assert_Equals ("A comment from Joe", Ada.Strings.Unbounded.To_String (C2.Get_Message),
                          "Invalid message");

         T.Assert (not C2.Get_User.Is_Null, "User associated with the comment should not be null");
--           T.Assert (not C2.Get_Entity_Type.Is_Null, "Entity type was not set");

         --  Check that we can access the user name (lazy load)
         Assert_Equals (T, "Joe", Ada.Strings.Unbounded.To_String (C2.Get_User.Get_Name.Value),
                        "Cannot load created object");
      end;
   end Test_Create_Object;

   --  ------------------------------
   --  Test creation and deletion of an object record
   --  ------------------------------
   procedure Test_Delete_Object (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("Joe (delete)");
         User.Set_Value (0);
         User.Save (S);
         S.Commit;
      end;

      --  Load it and delete it from another session.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);

         S.Begin_Transaction;
         U2.Delete (S);
         S.Commit;
      end;

      --  Try to load the deleted object.
      declare
         S  : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         U2 : Regtests.Simple.Model.User_Ref;
      begin
         U2.Load (S, User.Get_Id);
         T.Assert (False, "Load of a deleted object should raise NOT_FOUND");

      exception
         when ADO.Objects.NOT_FOUND =>
            null;
      end;
   end Test_Delete_Object;

   --  ------------------------------
   --  Test Is_Inserted and Is_Null
   --  ------------------------------
   procedure Test_Is_Inserted (T : in out Test) is
      User : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (not User.Is_Inserted, "A null object should not be marked as INSERTED");
      T.Assert (User.Is_Null, "A null object should be marked as NULL");

      --  Create an object within a transaction.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      begin
         S.Begin_Transaction;
         User.Set_Name ("John");
         T.Assert (not User.Is_Null, "User should not be NULL");
         T.Assert (not User.Is_Inserted, "User was not saved and not yet inserted in database");

         User.Set_Value (1);
         User.Save (S);
         S.Commit;
         T.Assert (User.Is_Inserted, "After a save operation, the user should be marked INSERTED");
         T.Assert (not User.Is_Null, "User should not be NULL");
      end;

      declare
         S    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         John : Regtests.Simple.Model.User_Ref;
      begin
         John.Load (S, User.Get_Id);
         T.Assert (John.Is_Inserted, "After a load, the object should be marked INSERTED");
         T.Assert (not John.Is_Null, "After a load, the object should not be NULL");
      end;
   end Test_Is_Inserted;

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

   --  ------------------------------
   --  Add the tests in the test suite
   --  ------------------------------
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Objects.Hash", Test_Key'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Get/Set", Test_Object_Ref'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Create", Test_Create_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Delete", Test_Delete_Object'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects.Is_Created", Test_Is_Inserted'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Integer)",
                       Test_Object_Nullable_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Entity_Type)",
                       Test_Object_Nullable_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Objects (Nullable_Time)",
                       Test_Object_Nullable_Time'Access);
   end Add_Tests;

end ADO.Objects.Tests;

Update Test_Op generic test to verify optimistic locking