-----------------------------------------------------------------------
--  gen-commands-model -- Model creation command for dynamo
--  Copyright (C) 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.
-----------------------------------------------------------------------

package Gen.Commands.Model is

   --  ------------------------------
   --  Model Creation Command
   --  ------------------------------
   --  This command adds a model file to the web application.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Model;

-----------------------------------------------------------------------
--  gen-commands-model -- Model creation command for dynamo
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package Gen.Commands.Model is

   --  ------------------------------
   --  Model Creation Command
   --  ------------------------------
   --  This command adds a model file to the web application.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Model;

Update to use the new command implementation


-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  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.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Enums;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;
with Gen.Model.Beans;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "enums" then
         return From.Enums_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given enum in the model.
   --  ------------------------------
   procedure Register_Enum (O      : in out Model_Definition;
                            Enum   : access Gen.Model.Enums.Enum_Definition'Class) is
      Name : constant String := Enum.Get_Name;
   begin
      Log.Info ("Registering enum {0}", Name);

      O.Register_Package (Enum.Pkg_Name, Enum.Package_Def);
      if Enum.Package_Def.Enums.Find (Name) /= null then
         raise Name_Exist with "Enum '" & Name & "' already defined";
      end if;
      Enum.Package_Def.Enums.Append (Enum.all'Access);
      O.Enums.Append (Enum.all'Access);
      Gen.Model.Mappings.Register_Type (To_String (Enum.Name), Enum.all'Access,
                                        Gen.Model.Mappings.T_ENUM);
   end Register_Enum;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
      Name : constant String := Table.Get_Name;
   begin
      Log.Info ("Registering table {0}", Name);

      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      if Table.Package_Def.Tables.Find (Name) /= null then
         raise Name_Exist with "Table '" & Name & "' already defined";
      end if;
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register the declaration of the given bean in the model.
   --  ------------------------------
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class) is
   begin
      O.Register_Package (Bean.Pkg_Name, Bean.Package_Def);
      Bean.Package_Def.Beans.Append (Bean.all'Access);
      O.Queries.Append (Bean.all'Access);
   end Register_Bean;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 and Name /= O.Pkg_Name then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;

               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Definition_Access := Table_List.Element (Table_Iter);
            begin
               if Table.all in Table_Definition'Class then
                  Prepare_Table (Table_Definition_Access (Table));
               else
                  Table.Prepare;
               end if;
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      Log.Info ("Preparing package {0}", O.Pkg_Name);

      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      O.Enums.Sort;
      O.Queries.Sort;
      Prepare_Tables (O.Enums);
      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Enums_Bean   := Util.Beans.Objects.To_Object (O.Enums'Unchecked_Access, STATIC);
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
      O.Tables.Sort;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  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.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Enums;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;
with Gen.Model.Beans;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "enums" then
         return From.Enums_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given enum in the model.
   --  ------------------------------
   procedure Register_Enum (O      : in out Model_Definition;
                            Enum   : access Gen.Model.Enums.Enum_Definition'Class) is
      Name : constant String := Enum.Get_Name;
   begin
      Log.Info ("Registering enum {0}", Name);

      O.Register_Package (Enum.Pkg_Name, Enum.Package_Def);
      if Enum.Package_Def.Enums.Find (Name) /= null then
         raise Name_Exist with "Enum '" & Name & "' already defined";
      end if;
      Enum.Package_Def.Enums.Append (Enum.all'Access);
      O.Enums.Append (Enum.all'Access);
      Gen.Model.Mappings.Register_Type (To_String (Enum.Name), Enum.all'Access,
                                        Gen.Model.Mappings.T_ENUM);
   end Register_Enum;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
      Name : constant String := Table.Get_Name;
   begin
      Log.Info ("Registering table {0}", Name);

      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      if Table.Package_Def.Tables.Find (Name) /= null then
         raise Name_Exist with "Table '" & Name & "' already defined";
      end if;
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register the declaration of the given bean in the model.
   --  ------------------------------
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class) is
   begin
      O.Register_Package (Bean.Pkg_Name, Bean.Package_Def);
      Bean.Package_Def.Beans.Append (Bean.all'Access);
      O.Queries.Append (Bean.all'Access);
   end Register_Bean;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 and Name /= O.Pkg_Name then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;

               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Definition_Access := Table_List.Element (Table_Iter);
            begin
               if Table.all in Table_Definition'Class then
                  Prepare_Table (Table_Definition_Access (Table));
               else
                  Table.Prepare;
               end if;
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      Log.Info ("Preparing package {0}", O.Pkg_Name);

      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      O.Enums.Sort;
      O.Queries.Sort;
      Prepare_Tables (O.Enums);
      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Enums_Bean   := Util.Beans.Objects.To_Object (O.Enums'Unchecked_Access, STATIC);
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Beans_Bean   := Util.Beans.Objects.To_Object (O.Beans'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
      O.Tables.Sort;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

Initialize the beans object to give access to the list of model Ada beans to generate


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

   --  ------------------------------
   --  Principal
   --  ------------------------------
   subtype Principal is Security.Permissions.Principal;
   subtype Principal_Access is Security.Permissions.Principal_Access;

end ASF.Principals;

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

   --  ------------------------------
   --  Principal
   --  ------------------------------
   subtype Principal is Security.Principal;
   subtype Principal_Access is Security.Principal_Access;

end ASF.Principals;

Update to use Security.Principal

Update to use Security.Principal


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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Wait for the fifo to become empty.
   --  ------------------------------
   procedure Wait_Empty (From : in out Fifo) is
   begin
      From.Buffer.Wait_Empty;
   end Wait_Empty;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length - (if Clear_On_Dequeue then 1 else 0) is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Wait for the queue to become empty.
      --  ------------------------------
      entry Wait_Empty when Count = 0 is
      begin
         null;
      end Wait_Empty;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access
                 := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Fix style warning

Fix style warning


-----------------------------------------------------------------------
--  util-encoders-quoted_printable -- Encode/Decode a stream in quoted-printable
--  Copyright (C) 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Characters.Handling;
with Interfaces;
package body Util.Encoders.Quoted_Printable is

   use Ada.Characters.Handling;
   use type Interfaces.Unsigned_8;

   function From_Hex (C : in Character) return Interfaces.Unsigned_8 is
     (if C >= '0' and C <= '9' then Character'Pos (C) - Character'Pos ('0')
      elsif C >= 'A' and C <= 'F' then Character'Pos (C) - Character'Pos ('A') + 10
      else 0);

   function From_Hex (C1, C2 : in Character) return Character is
     (Character'Val (From_Hex (C2) + Interfaces.Shift_Left (From_Hex (C1), 4)));

   --  ------------------------------
   --  Decode the Quoted-Printable string and return the result.
   --  When Strict is true, raises the Encoding_Error exception if the
   --  format is invalid.  Otherwise, ignore invalid encoding.
   --  ------------------------------
   function Decode (Content : in String;
                    Strict  : in Boolean := True) return String is
      Result    : String (1 .. Content'Length);
      Read_Pos  : Natural := Content'First;
      Write_Pos : Natural := Result'First - 1;
      C         : Character;
      C2        : Character;
   begin
      while Read_Pos <= Content'Last loop
         C := Content (Read_Pos);
         if C = '=' then
            exit when Read_Pos = Content'Last;
            if Read_Pos + 2 > Content'Last then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Read_Pos := Read_Pos + 1;
            C := Content (Read_Pos);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            C2 := Content (Read_Pos + 1);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := From_Hex (C, C2);
            Read_Pos := Read_Pos + 1;
         else
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := C;
         end if;
         Read_Pos := Read_Pos + 1;
      end loop;
      return Result (1 .. Write_Pos);
   end Decode;

   --  ------------------------------
   --  Decode the "Q" encoding, similar to Quoted-Printable but with
   --  spaces that can be replaced by '_'.
   --  See RFC 2047.
   --  ------------------------------
   function Q_Decode (Content : in String;
                      Strict  : in Boolean := True) return String is
      Result    : String (1 .. Content'Length);
      Read_Pos  : Natural := Content'First;
      Write_Pos : Natural := Result'First - 1;
      C         : Character;
      C2        : Character;
   begin
      while Read_Pos <= Content'Last loop
         C := Content (Read_Pos);
         if C = '=' then
            exit when Read_Pos = Content'Last;
            if Read_Pos + 2 > Content'Last then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Read_Pos := Read_Pos + 1;
            C := Content (Read_Pos);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            C2 := Content (Read_Pos + 1);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := From_Hex (C, C2);
            Read_Pos := Read_Pos + 1;
         elsif C = '_' then
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := C;
         else
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := C;
         end if;
         Read_Pos := Read_Pos + 1;
      end loop;
      return Result (1 .. Write_Pos);
   end Q_Decode;

end Util.Encoders.Quoted_Printable;

-----------------------------------------------------------------------
--  util-encoders-quoted_printable -- Encode/Decode a stream in quoted-printable
--  Copyright (C) 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Characters.Handling;
with Interfaces;
package body Util.Encoders.Quoted_Printable is

   use Ada.Characters.Handling;
   use type Interfaces.Unsigned_8;

   function From_Hex (C : in Character) return Interfaces.Unsigned_8 is
     (if C >= '0' and C <= '9' then Character'Pos (C) - Character'Pos ('0')
      elsif C >= 'A' and C <= 'F' then Character'Pos (C) - Character'Pos ('A') + 10
      else 0);

   function From_Hex (C1, C2 : in Character) return Character is
     (Character'Val (From_Hex (C2) + Interfaces.Shift_Left (From_Hex (C1), 4)));

   --  ------------------------------
   --  Decode the Quoted-Printable string and return the result.
   --  When Strict is true, raises the Encoding_Error exception if the
   --  format is invalid.  Otherwise, ignore invalid encoding.
   --  ------------------------------
   function Decode (Content : in String;
                    Strict  : in Boolean := True) return String is
      Result    : String (1 .. Content'Length);
      Read_Pos  : Natural := Content'First;
      Write_Pos : Natural := Result'First - 1;
      C         : Character;
      C2        : Character;
   begin
      while Read_Pos <= Content'Last loop
         C := Content (Read_Pos);
         if C = '=' then
            exit when Read_Pos = Content'Last;
            if Read_Pos + 2 > Content'Last then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Read_Pos := Read_Pos + 1;
            C := Content (Read_Pos);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            C2 := Content (Read_Pos + 1);
            if not Is_Hexadecimal_Digit (C) then
               exit when not Strict;
               raise Encoding_Error;
            end if;
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := From_Hex (C, C2);
            Read_Pos := Read_Pos + 1;
         else
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := C;
         end if;
         Read_Pos := Read_Pos + 1;
      end loop;
      return Result (1 .. Write_Pos);
   end Decode;

   --  ------------------------------
   --  Decode the "Q" encoding, similar to Quoted-Printable but with
   --  spaces that can be replaced by '_'.
   --  See RFC 2047.
   --  ------------------------------
   function Q_Decode (Content : in String) return String is
      Result    : String (1 .. Content'Length);
      Read_Pos  : Natural := Content'First;
      Write_Pos : Natural := Result'First - 1;
      C         : Character;
      C2        : Character;
   begin
      while Read_Pos <= Content'Last loop
         C := Content (Read_Pos);
         if C = '=' then
            exit when Read_Pos = Content'Last or else Read_Pos + 2 > Content'Last;
            Read_Pos := Read_Pos + 1;
            C := Content (Read_Pos);
            exit when not Is_Hexadecimal_Digit (C);
            C2 := Content (Read_Pos + 1);
            exit when  not Is_Hexadecimal_Digit (C);
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := From_Hex (C, C2);
            Read_Pos := Read_Pos + 1;
         elsif C = '_' then
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := ' ';
         else
            Write_Pos := Write_Pos + 1;
            Result (Write_Pos) := C;
         end if;
         Read_Pos := Read_Pos + 1;
      end loop;
      return Result (1 .. Write_Pos);
   end Q_Decode;

end Util.Encoders.Quoted_Printable;

Implement Q_Decode operation

Implement Q_Decode operation


-----------------------------------------------------------------------
--  util-http-clients -- HTTP Clients
--  Copyright (C) 2011, 2012, 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 Ada.Finalization;

with Util.Streams.Texts;
with Util.Serialize.IO.Form;
with Util.Http.Cookies;

--  == Client ==
--  The <tt>Util.Http.Clients</tt> package defines a set of API for an HTTP client to send
--  requests to an HTTP server.
--
--  === GET request ===
--  To retrieve a content using the HTTP GET operation, a client instance must be created.
--  The response is returned in a specific object that must therefore be declared:
--
--    Http     : Util.Http.Clients.Client;
--    Response : Util.Http.Clients.Response;
--
--  Before invoking the GET operation, the client can setup a number of HTTP headers.
--
--    Http.Add_Header ("X-Requested-By", "wget");
--
--  The GET operation is performed when the <tt>Get</tt> procedure is called:
--
--    Http.Get ("http://www.google.com", Response);
--
--  Once the response is received, the <tt>Response</tt> object contains the status of the
--  HTTP response, the HTTP reply headers and the body.  A response header can be obtained
--  by using the <tt>Get_Header</tt> function and the body using <tt>Get_Body</tt>:
--
--    Body : constant String := Response.Get_Body;
--
package Util.Http.Clients is

   Connection_Error : exception;

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with private;

   procedure Initialize (Form : in out Form_Data;
                         Size : in Positive);

   --  ------------------------------
   --  Http response
   --  ------------------------------
   --  The Response type represents a response returned by an HTTP request.
   type Response is limited new Abstract_Response with private;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean;

   --  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 (Reply  : in Response;
                        Name   : in String) return String;

   --  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 (Reply    : in out Response;
                         Name     : in String;
                         Value    : in String);

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

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Response) return Natural;

   --  ------------------------------
   --  Http client
   --  ------------------------------
   --  The Client type allows to execute HTTP GET/POST requests.
   type Client is limited new Abstract_Request with private;
   type Client_Access is access all Client;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  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 (Request : in Client;
                        Name    : in String) return String;

   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

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

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in Client;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Removes all headers with the given name.
   procedure Remove_Header (Request : in out Client;
                            Name    : in String);

   --  Adds the specified cookie to the request.  This method can be called multiple
   --  times to set more than one cookie.
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie);

   --  Set the timeout for the connection.
   procedure Set_Timeout (Request : in out Client;
                          Timeout : in Duration);

   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class);

   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class);
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in Form_Data'Class;
                   Reply   : out Response'Class);

   --  Execute an http PUT request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Put (Request : in out Client;
                  URL     : in String;
                  Data    : in String;
                  Reply   : out Response'Class);

   --  Execute a http DELETE request on the given URL.
   procedure Delete (Request : in out Client;
                     URL     : in String;
                     Reply   : out Response'Class);

private

   subtype Http_Request is Abstract_Request;
   subtype Http_Request_Access is Abstract_Request_Access;

   subtype Http_Response is Abstract_Response;
   subtype Http_Response_Access is Abstract_Response_Access;

   type Http_Manager is interface;
   type Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in Http_Manager;
                     Http     : in out Client'Class) is abstract;

   procedure Do_Get (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Post (Manager  : in Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is abstract;

   procedure Do_Put (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Delete (Manager  : in Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is abstract;

   --  Set the timeout for the connection.
   procedure Set_Timeout (Manager : in Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is abstract;

   Default_Http_Manager : Http_Manager_Access;

   type Response is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Response with record
      Delegate : Abstract_Response_Access;
   end record;

   --  Free the resource used by the response.
   overriding
   procedure Finalize (Reply : in out Response);

   type Client is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Request with record
      Manager  : Http_Manager_Access;
      Delegate : Http_Request_Access;
   end record;

   --  Initialize the client
   overriding
   procedure Initialize (Http : in out Client);

   overriding
   procedure Finalize (Http : in out Client);

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with record
      Buffer : aliased Util.Streams.Texts.Print_Stream;
   end record;

end Util.Http.Clients;

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

with Ada.Finalization;

with Util.Streams.Texts;
with Util.Serialize.IO.Form;
with Util.Http.Cookies;

--  == Client ==
--  The <tt>Util.Http.Clients</tt> package defines a set of API for an HTTP client to send
--  requests to an HTTP server.
--
--  === GET request ===
--  To retrieve a content using the HTTP GET operation, a client instance must be created.
--  The response is returned in a specific object that must therefore be declared:
--
--    Http     : Util.Http.Clients.Client;
--    Response : Util.Http.Clients.Response;
--
--  Before invoking the GET operation, the client can setup a number of HTTP headers.
--
--    Http.Add_Header ("X-Requested-By", "wget");
--
--  The GET operation is performed when the <tt>Get</tt> procedure is called:
--
--    Http.Get ("http://www.google.com", Response);
--
--  Once the response is received, the <tt>Response</tt> object contains the status of the
--  HTTP response, the HTTP reply headers and the body.  A response header can be obtained
--  by using the <tt>Get_Header</tt> function and the body using <tt>Get_Body</tt>:
--
--    Body : constant String := Response.Get_Body;
--
package Util.Http.Clients is

   Connection_Error : exception;

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with private;

   procedure Initialize (Form : in out Form_Data;
                         Size : in Positive);

   --  ------------------------------
   --  Http response
   --  ------------------------------
   --  The Response type represents a response returned by an HTTP request.
   type Response is limited new Abstract_Response with private;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean;

   --  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 (Reply  : in Response;
                        Name   : in String) return String;

   --  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 (Reply    : in out Response;
                         Name     : in String;
                         Value    : in String);

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

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Response) return Natural;

   --  ------------------------------
   --  Http client
   --  ------------------------------
   --  The Client type allows to execute HTTP GET/POST requests.
   type Client is limited new Abstract_Request with private;
   type Client_Access is access all Client;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  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 (Request : in Client;
                        Name    : in String) return String;

   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

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

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in Client;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Removes all headers with the given name.
   procedure Remove_Header (Request : in out Client;
                            Name    : in String);

   --  Adds the specified cookie to the request.  This method can be called multiple
   --  times to set more than one cookie.
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie);

   --  Set the timeout for the connection.
   procedure Set_Timeout (Request : in out Client;
                          Timeout : in Duration);

   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class);

   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class);
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in Form_Data'Class;
                   Reply   : out Response'Class);

   --  Execute an http PUT request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Put (Request : in out Client;
                  URL     : in String;
                  Data    : in String;
                  Reply   : out Response'Class);

   --  Execute an http PATCH request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Patch (Request : in out Client;
                    URL     : in String;
                    Data    : in String;
                    Reply   : out Response'Class);

   --  Execute a http DELETE request on the given URL.
   procedure Delete (Request : in out Client;
                     URL     : in String;
                     Reply   : out Response'Class);

   --  Execute an http HEAD request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Head (Request  : in out Client;
                   URL      : in String;
                   Reply    : out Response'Class);

   --  Execute an http OPTIONS request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Options (Request  : in out Client;
                      URL      : in String;
                      Reply    : out Response'Class);

private

   subtype Http_Request is Abstract_Request;
   subtype Http_Request_Access is Abstract_Request_Access;

   subtype Http_Response is Abstract_Response;
   subtype Http_Response_Access is Abstract_Response_Access;

   type Http_Manager is interface;
   type Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in Http_Manager;
                     Http     : in out Client'Class) is abstract;

   procedure Do_Get (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Head (Manager  : in Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Reply    : out Response'Class) is abstract;

   procedure Do_Post (Manager  : in Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is abstract;

   procedure Do_Put (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Patch (Manager  : in Http_Manager;
                       Http     : in Client'Class;
                       URI      : in String;
                       Data     : in String;
                       Reply    : out Response'Class) is abstract;

   procedure Do_Delete (Manager  : in Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is abstract;

   procedure Do_Options (Manager  : in Http_Manager;
                         Http     : in Client'Class;
                         URI      : in String;
                         Reply    : out Response'Class) is abstract;

   --  Set the timeout for the connection.
   procedure Set_Timeout (Manager : in Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is abstract;

   Default_Http_Manager : Http_Manager_Access;

   type Response is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Response with record
      Delegate : Abstract_Response_Access;
   end record;

   --  Free the resource used by the response.
   overriding
   procedure Finalize (Reply : in out Response);

   type Client is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Request with record
      Manager  : Http_Manager_Access;
      Delegate : Http_Request_Access;
   end record;

   --  Initialize the client
   overriding
   procedure Initialize (Http : in out Client);

   overriding
   procedure Finalize (Http : in out Client);

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with record
      Buffer : aliased Util.Streams.Texts.Print_Stream;
   end record;

end Util.Http.Clients;

Add support for the HTTP Head, Patch and Options


-----------------------------------------------------------------------
--  render -- XHTML Rendering example
--  Copyright (C) 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 Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Characters.Conversions;

with GNAT.Command_Line;

with Util.Files;

with Wiki.Utils;
with Wiki.Parsers;

--  This example reads an XHTML file and renders the result.
--  render -html -dotclear -markdown infile
--  render -text
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;
   use Ada.Strings.Unbounded;
   use Ada.Characters.Conversions;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Parsers.Wiki_Syntax_Type := Wiki.Parsers.SYNTAX_MARKDOWN;
begin
   loop
      case Getopt ("t f:") is
         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
               Ada.Text_IO.Put_Line (Value);
            end;

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

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Ada.Text_IO.Put_Line ("Usage: render [-DNAME=VALUE ] file");
               Ada.Text_IO.Put_Line ("Example: render -DcontextPath=/test samples/web/ajax.xhtml");
            end if;
            return;
         end if;
         Count := Count + 1;
         Util.Files.Read_File (Name, Data);
         if Html_Mode then
            Ada.Text_IO.Put_Line (Wiki.Utils.To_Html (To_Wide_Wide_String (To_String (Data)), Syntax));
         else
            Ada.Text_IO.Put_Line (Wiki.Utils.To_Text (To_Wide_Wide_String (To_String (Data)), Syntax));
         end if;
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;
end Render;

-----------------------------------------------------------------------
--  render -- XHTML Rendering example
--  Copyright (C) 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 Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Characters.Conversions;

with GNAT.Command_Line;

with Util.Files;

with Wiki.Utils;
with Wiki.Parsers;

--  This example reads an XHTML file and renders the result.
--  render -html -dotclear -markdown infile
--  render -text
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;
   use Ada.Strings.Unbounded;
   use Ada.Characters.Conversions;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Parsers.Wiki_Syntax_Type := Wiki.Parsers.SYNTAX_MARKDOWN;
begin
   loop
      case Getopt ("m M d c t f:") is
         when 'm' =>
            Syntax := Wiki.Parsers.SYNTAX_MARKDOWN;

         when 'M' =>
            Syntax := Wiki.Parsers.SYNTAX_MEDIA_WIKI;

         when 'c' =>
            Syntax := Wiki.Parsers.SYNTAX_CREOLE;

         when 'd' =>
            Syntax := Wiki.Parsers.SYNTAX_DOTCLEAR;

         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
               Ada.Text_IO.Put_Line (Value);
            end;

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

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Ada.Text_IO.Put_Line ("Usage: render [-DNAME=VALUE ] file");
               Ada.Text_IO.Put_Line ("Example: render -DcontextPath=/test samples/web/ajax.xhtml");
            end if;
            return;
         end if;
         Count := Count + 1;
         Util.Files.Read_File (Name, Data);
         if Html_Mode then
            Ada.Text_IO.Put_Line (Wiki.Utils.To_Html (To_Wide_Wide_String (To_String (Data)), Syntax));
         else
            Ada.Text_IO.Put_Line (Wiki.Utils.To_Text (To_Wide_Wide_String (To_String (Data)), Syntax));
         end if;
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;
end Render;

Add several options to render using different Wiki syntax


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

with ADO.Statements;
with ADO.Queries;

with Util.Log.Loggers;

with GNAT.Command_Line;

procedure Userdb is

   use ADO;
   use Ada;
   use Ada.Strings.Unbounded;
   use Samples.User.Model;
   use ADO.Statements;
   use GNAT.Command_Line;

   Factory    : ADO.Sessions.Factory.Session_Factory;

   User  : User_Ref;
   Users : User_Vector;

   procedure List_Users (Filter : in String);
   procedure List_User_Info;
   procedure Initialize (File : in String);

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_Users (Filter : in String) is
      use User_Vectors;
      DB : ADO.Sessions.Session := Factory.Get_Session;
      Statement : ADO.Statements.Query_Statement := DB.Create_Statement (Filter);
      Query : ADO.SQL.Query;
   begin
      List (Object => Users, Session => DB, Query => Query);
      if Users.Is_Empty then
         Text_IO.Put_Line ("List is empty");
      else
         declare
            Iter : User_Vectors.Cursor := First (Users);
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Get_Id) & "     "
                                 & To_String (User.Get_Name)
                                 & "    " & To_String (User.Get_Email));
               User_Vectors.Next (Iter);
            end loop;
         end;
      end if;

      Statement := DB.Create_Statement ("select count(*) from user");
      Statement.Execute;
      if not Statement.Has_Elements then
         Text_IO.Put_Line ("Count query failed...");
      end if;
      declare
         Count : constant Integer := Statement.Get_Integer (0);
      begin
         Text_IO.Put_Line ("Count: " & Integer'Image (Count));
      end;
   end List_Users;

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_User_Info is
      use Samples.User.Model.User_Info_Vectors;
      DB      : ADO.Sessions.Session := Factory.Get_Session;
      Users   : Samples.User.Model.User_Info_Vector;
      Context : ADO.Queries.Context;
   begin
      Context.Set_Query (Samples.User.Model.Query_User_List);
      List (Object => Users, Session => DB, Context => Context);

      if Users.Is_Empty then
         Text_IO.Put_Line ("User info list is empty");
      else
         declare
            Iter : Cursor := First (Users);
            User : Samples.User.Model.User_Info;
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Id) & "     "
                                 & To_String (User.Name)
                                 & "    " & To_String (User.Email));
               Next (Iter);
            end loop;
         end;
      end if;
   end List_User_Info;

   procedure Initialize (File : in String) is
   begin
      Util.Log.Loggers.Initialize (File);
      ADO.Drivers.Initialize (File);
   end Initialize;

begin
   Initialize ("samples.properties");
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB    : ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      DB.Begin_Transaction;
      List_User_Info;

      List_Users (Filter => "");

      loop
         declare
            Name : constant String := Get_Argument;
         begin
            exit when Name = "";

            Query.Bind_Param (1, Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => DB, Query => Query, Found => Found);
            if User.Is_Null or not Found then
               User.Set_Name (Name);
               User.Set_Email (Name & "@gmail.com");
               User.Set_Description ("My friend " & Name);
               --  User.Set_Password ("my password");
               User.Set_Status (0);
               User.Save (DB);

               Text_IO.Put_Line ("User created: " & Identifier'Image (User.Get_Id));
            else
               Text_IO.Put_Line ("User " & Name & ": " & Identifier'Image (User.Get_Id));
            end if;
         end;
      end loop;
      DB.Rollback;

   exception
      when ADO.Sessions.NOT_FOUND =>
         Text_IO.Put_Line ("User 23 does not exist");
   end;
   Text_IO.Put_Line ("Exiting");
end Userdb;

-----------------------------------------------------------------------
--  userdb -- Example to find/create an object from the database
--  Copyright (C) 2010, 2011, 2012, 2013 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 ADO;
with ADO.Drivers.Initializer;
with ADO.Sessions;
with ADO.SQL;
with ADO.Sessions.Factory;
with Samples.User.Model;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with ADO.Statements;
with ADO.Queries;

with Util.Log.Loggers;

with GNAT.Command_Line;

procedure Userdb is

   use ADO;
   use Ada;
   use Ada.Strings.Unbounded;
   use Samples.User.Model;
   use ADO.Statements;
   use GNAT.Command_Line;

   Factory    : ADO.Sessions.Factory.Session_Factory;

   User  : User_Ref;
   Users : User_Vector;

   procedure List_Users (Filter : in String);
   procedure List_User_Info;
   procedure Initialize (File : in String);

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_Users (Filter : in String) is
      use User_Vectors;
      DB : ADO.Sessions.Session := Factory.Get_Session;
      Statement : ADO.Statements.Query_Statement := DB.Create_Statement (Filter);
      Query : ADO.SQL.Query;
   begin
      List (Object => Users, Session => DB, Query => Query);
      if Users.Is_Empty then
         Text_IO.Put_Line ("List is empty");
      else
         declare
            Iter : User_Vectors.Cursor := First (Users);
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Get_Id) & "     "
                                 & To_String (User.Get_Name)
                                 & "    " & To_String (User.Get_Email));
               User_Vectors.Next (Iter);
            end loop;
         end;
      end if;

      Statement := DB.Create_Statement ("select count(*) from user");
      Statement.Execute;
      if not Statement.Has_Elements then
         Text_IO.Put_Line ("Count query failed...");
      end if;
      declare
         Count : constant Integer := Statement.Get_Integer (0);
      begin
         Text_IO.Put_Line ("Count: " & Integer'Image (Count));
      end;
   end List_Users;

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_User_Info is
      use Samples.User.Model.User_Info_Vectors;
      DB      : ADO.Sessions.Session := Factory.Get_Session;
      Users   : Samples.User.Model.User_Info_Vector;
      Context : ADO.Queries.Context;
   begin
      Context.Set_Query (Samples.User.Model.Query_User_List);
      List (Object => Users, Session => DB, Context => Context);

      if Users.Is_Empty then
         Text_IO.Put_Line ("User info list is empty");
      else
         declare
            Iter : Cursor := First (Users);
            User : Samples.User.Model.User_Info;
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Id) & "     "
                                 & To_String (User.Name)
                                 & "    " & To_String (User.Email));
               Next (Iter);
            end loop;
         end;
      end if;
   end List_User_Info;

   procedure Initialize (File : in String) is
      procedure Init is new ADO.Drivers.Initializer (String, ADO.Drivers.Initialize);
   begin
      Util.Log.Loggers.Initialize (File);
      Init (File);
   end Initialize;

begin
   Initialize ("samples.properties");
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB    : ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      DB.Begin_Transaction;
      List_User_Info;

      List_Users (Filter => "");

      loop
         declare
            Name : constant String := Get_Argument;
         begin
            exit when Name = "";

            Query.Bind_Param (1, Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => DB, Query => Query, Found => Found);
            if User.Is_Null or not Found then
               User.Set_Name (Name);
               User.Set_Email (Name & "@gmail.com");
               User.Set_Description ("My friend " & Name);
               --  User.Set_Password ("my password");
               User.Set_Status (0);
               User.Save (DB);

               Text_IO.Put_Line ("User created: " & Identifier'Image (User.Get_Id));
            else
               Text_IO.Put_Line ("User " & Name & ": " & Identifier'Image (User.Get_Id));
            end if;
         end;
      end loop;
      DB.Rollback;

   exception
      when ADO.Sessions.NOT_FOUND =>
         Text_IO.Put_Line ("User 23 does not exist");
   end;
   Text_IO.Put_Line ("Exiting");
end Userdb;

Update the driver initialization

Update the driver initialization