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

with Util.Tests;
with Util.Log.Loggers;

with ASF.Principals;
with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

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

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Signup_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.SIGNUP_KEY);
      Password_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.RESET_PASSWORD_KEY);
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ? AND o.kind = ?");
      Query.Bind_Param (1, Email);
      Query.Bind_Param (2, Signup_Kind);
      Key.Find (DB, Query, Found);
      if not Found then
         Query.Bind_Param (2, Password_Kind);
         Key.Find (DB, Query, Found);
         if not Found then
            Log.Error ("Cannot find access key for email {0}", Email);
         end if;
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request'Class) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   --  ------------------------------
   --  Simulate the recovery password process for the given user.
   --  ------------------------------
   procedure Recover_Password (Email : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
         Log.Error ("Invalid redirect after lost password");
      end if;

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         if not Key.Is_Null then
            Log.Error ("There is no access key associated with the user");
         end if;

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "admin");
         Request.Set_Parameter ("reset-password", "1");
         ASF.Tests.Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
            Log.Error ("Invalid response");
         end if;

         --  Check that the user is logged and we have a user principal now.
         if Request.Get_User_Principal = null then
            Log.Error ("A user principal should be defined");
         end if;
      end;
   end Recover_Password;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

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

with Util.Tests;
with Util.Log.Loggers;

with ASF.Principals;
with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

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

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email, Key, True);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email, Key, True);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Signup_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.SIGNUP_KEY);
      Password_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.RESET_PASSWORD_KEY);
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ? AND o.kind = ?");
      Query.Bind_Param (1, Email);
      Query.Bind_Param (2, Signup_Kind);
      Key.Find (DB, Query, Found);
      if not Found then
         Query.Bind_Param (2, Password_Kind);
         Key.Find (DB, Query, Found);
         if not Found then
            Log.Error ("Cannot find access key for email {0}", Email);
         end if;
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request'Class) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   --  ------------------------------
   --  Simulate the recovery password process for the given user.
   --  ------------------------------
   procedure Recover_Password (Email : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
         Log.Error ("Invalid redirect after lost password");
      end if;

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         if not Key.Is_Null then
            Log.Error ("There is no access key associated with the user");
         end if;

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "admin");
         Request.Set_Parameter ("reset-password", "1");
         ASF.Tests.Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
            Log.Error ("Invalid response");
         end if;

         --  Check that the user is logged and we have a user principal now.
         if Request.Get_User_Principal = null then
            Log.Error ("A user principal should be defined");
         end if;
      end;
   end Recover_Password;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

Update calls to Create_User

Update calls to Create_User


-----------------------------------------------------------------------
--  gen-commands-templates -- Template based command
--  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 Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Directories;

with GNAT.Command_Line;

with Gen.Artifacts;

with Util.Log.Loggers;
with Util.Files;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
package body Gen.Commands.Templates is

   use Ada.Strings.Unbounded;
   use Util.Log;
   use GNAT.Command_Line;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Templates");

   --  ------------------------------
   --  Page Creation Command
   --  ------------------------------
   --  This command adds a XHTML page to the web application.

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      function Get_Output_Dir return String;

      function Get_Output_Dir return String is
         Dir        : constant String := Generator.Get_Result_Directory;
      begin
         if Length (Cmd.Base_Dir) = 0 then
            return Dir;
         else
            return Util.Files.Compose (Dir, To_String (Cmd.Base_Dir));
         end if;
      end Get_Output_Dir;

      Out_Dir : constant String := Get_Output_Dir;
      Iter    : Param_Vectors.Cursor := Cmd.Params.First;
   begin
      Generator.Read_Project ("dynamo.xml", False);
      while Param_Vectors.Has_Element (Iter) loop
         declare
            P     : constant Param := Param_Vectors.Element (Iter);
            Value : constant String := Get_Argument;
         begin
            if not P.Is_Optional and Value'Length = 0 then
               Generator.Error ("Missing argument for {0}", To_String (P.Argument));
               return;
            end if;
            Generator.Set_Global (To_String (P.Name), Value);
         end;
         Param_Vectors.Next (Iter);
      end loop;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Out_Dir);
      declare
         Iter : Util.Strings.Sets.Cursor := Cmd.Templates.First;
      begin
         while Util.Strings.Sets.Has_Element (Iter) loop
            Gen.Generator.Generate (Generator, Gen.Artifacts.ITERATION_TABLE,
                                    Util.Strings.Sets.Element (Iter));
            Util.Strings.Sets.Next (Iter);
         end loop;
      end;
   end Execute;

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

      use Ada.Text_IO;
   begin
      Put_Line (To_String (Cmd.Name) & ": " & To_String (Cmd.Title));
      Put_Line ("Usage: " & To_String (Cmd.Usage));
      New_Line;
      Put_Line (To_String (Cmd.Help_Msg));
   end Help;

   type Command_Fields is (FIELD_NAME,
                           FIELD_HELP,
                           FIELD_USAGE,
                           FIELD_TITLE,
                           FIELD_BASEDIR,
                           FIELD_PARAM,
                           FIELD_PARAM_NAME,
                           FIELD_PARAM_OPTIONAL,
                           FIELD_PARAM_ARG,
                           FIELD_TEMPLATE,
                           FIELD_COMMAND);

   type Command_Loader is record
      Command : Command_Access := null;
      P       : Param;
   end record;
   type Command_Loader_Access is access all Command_Loader;

   procedure Set_Member (Closure : in out Command_Loader;
                         Field   : in Command_Fields;
                         Value   : in Util.Beans.Objects.Object);

   function To_String (Value : in Util.Beans.Objects.Object) return Unbounded_String;

   --  ------------------------------
   --  Convert the object value into a string and trim any space/tab/newlines.
   --  ------------------------------
   function To_String (Value : in Util.Beans.Objects.Object) return Unbounded_String is
      Result    : constant String := Util.Beans.Objects.To_String (Value);
      First_Pos : Natural := Result'First;
      Last_Pos  : Natural := Result'Last;
      C : Character;
   begin
      while First_Pos <= Last_Pos loop
         C := Result (First_Pos);
         exit when C /= ' ' and C /= ASCII.LF and C /= ASCII.CR and C /= ASCII.HT;
         First_Pos := First_Pos + 1;
      end loop;
      while Last_Pos >= First_Pos loop
         C := Result (Last_Pos);
         exit when C /= ' ' and C /= ASCII.LF and C /= ASCII.CR and C /= ASCII.HT;
         Last_Pos := Last_Pos - 1;
      end loop;
      return To_Unbounded_String (Result (First_Pos .. Last_Pos));
   end To_String;

   procedure Set_Member (Closure : in out Command_Loader;
                         Field   : in Command_Fields;
                         Value   : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      if Field = FIELD_COMMAND then
         if Closure.Command /= null then
            Log.Info ("Adding command {0}", Closure.Command.Name);

            Add_Command (Name => To_String (Closure.Command.Name),
                         Cmd  => Closure.Command.all'Access);
            Closure.Command := null;
         end if;
      else
         if Closure.Command = null then
            Closure.Command := new Gen.Commands.Templates.Command;
         end if;
         case Field is
            when FIELD_NAME =>
               Closure.Command.Name := To_String (Value);

            when FIELD_TITLE =>
               Closure.Command.Title := To_String (Value);

            when FIELD_USAGE =>
               Closure.Command.Usage := To_String (Value);

            when FIELD_HELP =>
               Closure.Command.Help_Msg := To_String (Value);

            when FIELD_TEMPLATE =>
               Closure.Command.Templates.Include (To_String (Value));

            when FIELD_PARAM_NAME =>
               Closure.P.Name := To_Unbounded_String (Value);

            when FIELD_PARAM_OPTIONAL =>
               Closure.P.Is_Optional := To_Boolean (Value);

            when FIELD_PARAM_ARG =>
               Closure.P.Argument := To_Unbounded_String (Value);

            when FIELD_PARAM =>
               Closure.P.Value := To_Unbounded_String (Value);
               Closure.Command.Params.Append (Closure.P);
               Closure.P.Name        := Ada.Strings.Unbounded.Null_Unbounded_String;
               Closure.P.Argument    := Ada.Strings.Unbounded.Null_Unbounded_String;
               Closure.P.Is_Optional := False;

            when FIELD_BASEDIR =>
               Closure.Command.Base_Dir := To_Unbounded_String (Value);

            when FIELD_COMMAND =>
               null;

         end case;
      end if;
   end Set_Member;

   package Command_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Command_Loader,
                                               Element_Type_Access => Command_Loader_Access,
                                               Fields              => Command_Fields,
                                               Set_Member          => Set_Member);

   Cmd_Mapper : aliased Command_Mapper.Mapper;

   --  ------------------------------
   --  Read the template commands defined in dynamo configuration directory.
   --  ------------------------------
   procedure Read_Commands (Generator : in out Gen.Generator.Handler) is

      procedure Read_Command (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      --  ------------------------------
      --  Read the XML command file.
      --  ------------------------------
      procedure Read_Command (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         pragma Unreferenced (Name);

         Loader : aliased Command_Loader;
         Reader : Util.Serialize.IO.XML.Parser;
      begin
         Log.Info ("Reading command file '{0}'", File_Path);
         Done := False;

         --  Create the mapping to load the XML command file.
         Reader.Add_Mapping ("commands", Cmd_Mapper'Access);

         --  Set the context for Set_Member.
         Command_Mapper.Set_Context (Reader, Loader'Unchecked_Access);

         --  Read the XML command file.
         Reader.Parse (File_Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Generator.Error ("Command file {0} does not exist", File_Path);
      end Read_Command;

      Config_Dir : constant String := Generator.Get_Config_Directory;
      Cmd_Dir    : constant String := Generator.Get_Parameter ("generator.commands.dir");
      Path       : constant String := Util.Files.Compose (Config_Dir, Cmd_Dir);
   begin
      Log.Debug ("Checking commands in {0}", Path);

      if Ada.Directories.Exists (Path) then
         Util.Files.Iterate_Files_Path (Path    => Path,
                                        Pattern => "*.xml",
                                        Process => Read_Command'Access);
      end if;
   end Read_Commands;

begin
   --  Setup the mapper to load XML commands.
   Cmd_Mapper.Add_Mapping ("command/name", FIELD_NAME);
   Cmd_Mapper.Add_Mapping ("command/title", FIELD_TITLE);
   Cmd_Mapper.Add_Mapping ("command/usage", FIELD_USAGE);
   Cmd_Mapper.Add_Mapping ("command/help", FIELD_HELP);
   Cmd_Mapper.Add_Mapping ("command/basedir", FIELD_BASEDIR);
   Cmd_Mapper.Add_Mapping ("command/param", FIELD_PARAM);
   Cmd_Mapper.Add_Mapping ("command/param/@name", FIELD_PARAM_NAME);
   Cmd_Mapper.Add_Mapping ("command/param/@optional", FIELD_PARAM_OPTIONAL);
   Cmd_Mapper.Add_Mapping ("command/param/@arg", FIELD_PARAM_ARG);
   Cmd_Mapper.Add_Mapping ("command/template", FIELD_TEMPLATE);
   Cmd_Mapper.Add_Mapping ("command", FIELD_COMMAND);
end Gen.Commands.Templates;

-----------------------------------------------------------------------
--  gen-commands-templates -- Template based command
--  Copyright (C) 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 Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Directories;
with Ada.Streams.Stream_IO;

with GNAT.Command_Line;

with Gen.Artifacts;

with EL.Contexts.Default;
with EL.Expressions;
with EL.Variables.Default;

with Util.Log.Loggers;
with Util.Files;
with Util.Streams.Files;
with Util.Streams.Texts;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
package body Gen.Commands.Templates is

   use Ada.Strings.Unbounded;
   use GNAT.Command_Line;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Commands.Templates");

   --  Apply the patch instruction
   procedure Patch_File (Generator : in out Gen.Generator.Handler;
                         Info      : in Patch);

   function Match_Line (Line    : in String;
                        Pattern : in String) return Boolean;

   --  ------------------------------
   --  Check if the line matches the pseudo pattern.
   --  ------------------------------
   function Match_Line (Line    : in String;
                        Pattern : in String) return Boolean is
      L_Pos : Natural := Line'First;
      P_Pos : Natural := Pattern'First;
   begin
      while P_Pos <= Pattern'Last loop
         if L_Pos > Line'Last then
            return False;
         end if;
         if Line (L_Pos) = Pattern (P_Pos) then
            if Pattern (P_Pos) /= ' ' then
               P_Pos := P_Pos + 1;
            end if;
            L_Pos := L_Pos + 1;
         elsif Pattern (P_Pos) = ' ' and Line (L_Pos) = Pattern (P_Pos + 1) then
            P_Pos := P_Pos + 2;
            L_Pos := L_Pos + 1;
         elsif Pattern (P_Pos) = ' ' and Pattern (P_Pos + 1) = '*' then
            P_Pos := P_Pos + 1;
            L_Pos := L_Pos + 1;
         elsif Pattern (P_Pos) = '*' and Line (L_Pos) = Pattern (P_Pos + 1) then
            P_Pos := P_Pos + 2;
            L_Pos := L_Pos + 1;
         elsif Pattern (P_Pos) = '*' and Line (L_Pos) /= ' ' then
            L_Pos := L_Pos + 1;
         else
            return False;
         end if;
      end loop;
      return True;
   end Match_Line;

   --  ------------------------------
   --  Apply the patch instruction
   --  ------------------------------
   procedure Patch_File (Generator : in out Gen.Generator.Handler;
                         Info      : in Patch) is
      procedure Save_Output (H       : in out Gen.Generator.Handler;
                             File    : in String;
                             Content : in Ada.Strings.Unbounded.Unbounded_String);

      Ctx         : EL.Contexts.Default.Default_Context;
      Variables   : aliased EL.Variables.Default.Default_Variable_Mapper;

      procedure Save_Output (H       : in out Gen.Generator.Handler;
                             File    : in String;
                             Content : in Ada.Strings.Unbounded.Unbounded_String) is

         type State is (MATCH_AFTER, MATCH_BEFORE, MATCH_DONE);

         Output_Dir    : constant String := H.Get_Result_Directory;
         Path          : constant String := Util.Files.Compose (Output_Dir, File);
         Tmp_File      : constant String := Path & ".tmp";
         Line_Number   : Natural := 0;
         After_Pos     : Natural := 1;
         Current_State : State := MATCH_AFTER;
         Tmp_Output    : aliased Util.Streams.Files.File_Stream;
         Output        : Util.Streams.Texts.Print_Stream;

         procedure Process (Line : in String);

         procedure Process (Line : in String) is
         begin
            Line_Number := Line_Number + 1;
            case Current_State is
            when MATCH_AFTER =>
               if Match_Line (Line, Info.After.Element (After_Pos)) then
                  Log.Info ("Match after at line {0}", Natural'Image (Line_Number));
                  After_Pos := After_Pos + 1;
                  if After_Pos >= Natural (Info.After.Length) then
                     Current_State := MATCH_BEFORE;
                  end if;
               end if;

            when MATCH_BEFORE =>
               if Match_Line (Line, To_String (Info.Before)) then
                  Log.Info ("Match before at line {0}", Natural'Image (Line_Number));
                  Log.Info ("Add content {0}", Content);
                  Output.Write (Content);
                  Current_State := MATCH_DONE;
               end if;

            when MATCH_DONE =>
               null;

            end case;
            Output.Write (Line);
            Output.Write (ASCII.LF);
         end Process;

      begin
         Tmp_Output.Create (Name => Tmp_File, Mode => Ada.Streams.Stream_IO.Out_File);
         Output.Initialize (Tmp_Output'Unchecked_Access);
         Util.Files.Read_File (Path, Process'Access);
         Output.Close;
         if Current_State /= MATCH_DONE then
            H.Error ("Patch {0} failed", Path);
            Ada.Directories.Delete_File (Tmp_File);
         else
            Ada.Directories.Delete_File (Path);
            Ada.Directories.Rename (Old_Name => Tmp_File,
                                    New_Name => Path);
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            H.Error ("Cannot patch file {0}", Path);
      end Save_Output;

   begin
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      Gen.Generator.Generate (Generator, Gen.Artifacts.ITERATION_TABLE,
                              To_String (Info.Template), Save_Output'Access);
   end Patch_File;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      function Get_Output_Dir return String;

      function Get_Output_Dir return String is
         Dir        : constant String := Generator.Get_Result_Directory;
      begin
         if Length (Cmd.Base_Dir) = 0 then
            return Dir;
         else
            return Util.Files.Compose (Dir, To_String (Cmd.Base_Dir));
         end if;
      end Get_Output_Dir;

      Out_Dir : constant String := Get_Output_Dir;
      Iter    : Param_Vectors.Cursor := Cmd.Params.First;
   begin
      Generator.Read_Project ("dynamo.xml", False);
      while Param_Vectors.Has_Element (Iter) loop
         declare
            P     : constant Param := Param_Vectors.Element (Iter);
            Value : constant String := Get_Argument;
         begin
            if not P.Is_Optional and Value'Length = 0 then
               Generator.Error ("Missing argument for {0}", To_String (P.Argument));
               return;
            end if;
            Generator.Set_Global (To_String (P.Name), Value);
         end;
         Param_Vectors.Next (Iter);
      end loop;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Out_Dir);
      declare
         Iter : Util.Strings.Sets.Cursor := Cmd.Templates.First;
      begin
         while Util.Strings.Sets.Has_Element (Iter) loop
            Gen.Generator.Generate (Generator, Gen.Artifacts.ITERATION_TABLE,
                                    Util.Strings.Sets.Element (Iter),
                                    Gen.Generator.Save_Content'Access);
            Util.Strings.Sets.Next (Iter);
         end loop;
      end;

      --  Apply the patch instructions defined for the command.
      declare
         Iter : Patch_Vectors.Cursor := Cmd.Patches.First;
      begin
         while Patch_Vectors.Has_Element (Iter) loop
            Patch_File (Generator, Patch_Vectors.Element (Iter));
            Patch_Vectors.Next (Iter);
         end loop;
      end;
   end Execute;

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

      use Ada.Text_IO;
   begin
      Put_Line (To_String (Cmd.Name) & ": " & To_String (Cmd.Title));
      Put_Line ("Usage: " & To_String (Cmd.Usage));
      New_Line;
      Put_Line (To_String (Cmd.Help_Msg));
   end Help;

   type Command_Fields is (FIELD_NAME,
                           FIELD_HELP,
                           FIELD_USAGE,
                           FIELD_TITLE,
                           FIELD_BASEDIR,
                           FIELD_PARAM,
                           FIELD_PARAM_NAME,
                           FIELD_PARAM_OPTIONAL,
                           FIELD_PARAM_ARG,
                           FIELD_TEMPLATE,
                           FIELD_PATCH,
                           FIELD_AFTER,
                           FIELD_BEFORE,
                           FIELD_INSERT_TEMPLATE,
                           FIELD_COMMAND);

   type Command_Loader is record
      Command : Command_Access := null;
      P       : Param;
      Info    : Patch;
   end record;
   type Command_Loader_Access is access all Command_Loader;

   procedure Set_Member (Closure : in out Command_Loader;
                         Field   : in Command_Fields;
                         Value   : in Util.Beans.Objects.Object);

   function To_String (Value : in Util.Beans.Objects.Object) return Unbounded_String;

   --  ------------------------------
   --  Convert the object value into a string and trim any space/tab/newlines.
   --  ------------------------------
   function To_String (Value : in Util.Beans.Objects.Object) return Unbounded_String is
      Result    : constant String := Util.Beans.Objects.To_String (Value);
      First_Pos : Natural := Result'First;
      Last_Pos  : Natural := Result'Last;
      C : Character;
   begin
      while First_Pos <= Last_Pos loop
         C := Result (First_Pos);
         exit when C /= ' ' and C /= ASCII.LF and C /= ASCII.CR and C /= ASCII.HT;
         First_Pos := First_Pos + 1;
      end loop;
      while Last_Pos >= First_Pos loop
         C := Result (Last_Pos);
         exit when C /= ' ' and C /= ASCII.LF and C /= ASCII.CR and C /= ASCII.HT;
         Last_Pos := Last_Pos - 1;
      end loop;
      return To_Unbounded_String (Result (First_Pos .. Last_Pos));
   end To_String;

   procedure Set_Member (Closure : in out Command_Loader;
                         Field   : in Command_Fields;
                         Value   : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      if Field = FIELD_COMMAND then
         if Closure.Command /= null then
            Log.Info ("Adding command {0}", Closure.Command.Name);

            Add_Command (Name => To_String (Closure.Command.Name),
                         Cmd  => Closure.Command.all'Access);
            Closure.Command := null;
         end if;
      else
         if Closure.Command = null then
            Closure.Command := new Gen.Commands.Templates.Command;
         end if;
         case Field is
            when FIELD_NAME =>
               Closure.Command.Name := To_String (Value);

            when FIELD_TITLE =>
               Closure.Command.Title := To_String (Value);

            when FIELD_USAGE =>
               Closure.Command.Usage := To_String (Value);

            when FIELD_HELP =>
               Closure.Command.Help_Msg := To_String (Value);

            when FIELD_TEMPLATE =>
               Closure.Command.Templates.Include (To_String (Value));

            when FIELD_PARAM_NAME =>
               Closure.P.Name := To_Unbounded_String (Value);

            when FIELD_PARAM_OPTIONAL =>
               Closure.P.Is_Optional := To_Boolean (Value);

            when FIELD_PARAM_ARG =>
               Closure.P.Argument := To_Unbounded_String (Value);

            when FIELD_PARAM =>
               Closure.P.Value := To_Unbounded_String (Value);
               Closure.Command.Params.Append (Closure.P);
               Closure.P.Name        := Ada.Strings.Unbounded.Null_Unbounded_String;
               Closure.P.Argument    := Ada.Strings.Unbounded.Null_Unbounded_String;
               Closure.P.Is_Optional := False;

            when FIELD_BASEDIR =>
               Closure.Command.Base_Dir := To_Unbounded_String (Value);

            when FIELD_COMMAND =>
               null;

            when FIELD_INSERT_TEMPLATE =>
               Closure.Info.Template := To_Unbounded_String (Value);

            when FIELD_AFTER =>
               Closure.Info.After.Append (To_String (Value));

            when FIELD_BEFORE =>
               Closure.Info.Before := To_Unbounded_String (Value);

            when FIELD_PATCH =>
               Closure.Command.Patches.Append (Closure.Info);
               Closure.Info.After.Clear;
               Closure.Info.Before := To_Unbounded_String ("");

         end case;
      end if;
   end Set_Member;

   package Command_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Command_Loader,
                                               Element_Type_Access => Command_Loader_Access,
                                               Fields              => Command_Fields,
                                               Set_Member          => Set_Member);

   Cmd_Mapper : aliased Command_Mapper.Mapper;

   --  ------------------------------
   --  Read the template commands defined in dynamo configuration directory.
   --  ------------------------------
   procedure Read_Commands (Generator : in out Gen.Generator.Handler) is

      procedure Read_Command (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      --  ------------------------------
      --  Read the XML command file.
      --  ------------------------------
      procedure Read_Command (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         pragma Unreferenced (Name);

         Loader : aliased Command_Loader;
         Reader : Util.Serialize.IO.XML.Parser;
      begin
         Log.Info ("Reading command file '{0}'", File_Path);
         Done := False;

         --  Create the mapping to load the XML command file.
         Reader.Add_Mapping ("commands", Cmd_Mapper'Access);

         --  Set the context for Set_Member.
         Command_Mapper.Set_Context (Reader, Loader'Unchecked_Access);

         --  Read the XML command file.
         Reader.Parse (File_Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Generator.Error ("Command file {0} does not exist", File_Path);
      end Read_Command;

      Config_Dir : constant String := Generator.Get_Config_Directory;
      Cmd_Dir    : constant String := Generator.Get_Parameter ("generator.commands.dir");
      Path       : constant String := Util.Files.Compose (Config_Dir, Cmd_Dir);
   begin
      Log.Debug ("Checking commands in {0}", Path);

      if Ada.Directories.Exists (Path) then
         Util.Files.Iterate_Files_Path (Path    => Path,
                                        Pattern => "*.xml",
                                        Process => Read_Command'Access);
      end if;
   end Read_Commands;

begin
   --  Setup the mapper to load XML commands.
   Cmd_Mapper.Add_Mapping ("command/name", FIELD_NAME);
   Cmd_Mapper.Add_Mapping ("command/title", FIELD_TITLE);
   Cmd_Mapper.Add_Mapping ("command/usage", FIELD_USAGE);
   Cmd_Mapper.Add_Mapping ("command/help", FIELD_HELP);
   Cmd_Mapper.Add_Mapping ("command/basedir", FIELD_BASEDIR);
   Cmd_Mapper.Add_Mapping ("command/param", FIELD_PARAM);
   Cmd_Mapper.Add_Mapping ("command/param/@name", FIELD_PARAM_NAME);
   Cmd_Mapper.Add_Mapping ("command/param/@optional", FIELD_PARAM_OPTIONAL);
   Cmd_Mapper.Add_Mapping ("command/param/@arg", FIELD_PARAM_ARG);
   Cmd_Mapper.Add_Mapping ("command/patch/template", FIELD_INSERT_TEMPLATE);
   Cmd_Mapper.Add_Mapping ("command/patch/after", FIELD_AFTER);
   Cmd_Mapper.Add_Mapping ("command/patch/before", FIELD_BEFORE);
   Cmd_Mapper.Add_Mapping ("command/template", FIELD_TEMPLATE);
   Cmd_Mapper.Add_Mapping ("command/patch", FIELD_PATCH);
   Cmd_Mapper.Add_Mapping ("command", FIELD_COMMAND);
end Gen.Commands.Templates;

Implement some basic support to patch files and insert some template generation content in existing files


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

with Ada.Finalization;
with Util.Concurrent.Counters;

--  == Introduction ==
--  The Util.Concurrent.Arrays generic package defines an array which provides a
--  concurrent read only access and a protected exclusive write access.  This implementation
--  is intended to be used in applications that have to frequently iterate over the array
--  content.  Adding or removing elements in the array is assumed to be a not so frequent
--  operation.  Based on these assumptions, updating the array is implemented by
--  using the <tt>copy on write</tt> design pattern.  Read access is provided through a
--  reference object that can be shared by multiple readers.
--
--  == Declaration ==
--  The package must be instantiated using the element type representing the array element.
--
--    package My_Array is new Util.Concurrent.Arrays (Element_Type => Integer);
--
--  == Adding Elements ==
--  The vector instance is declared and elements are added as follows:
--
--     C : My_Array.Vector;
--
--     C.Append (E1);
--
--  == Iterating over the array ==
--  To read and iterate over the vector, a task will get a reference to the vector array
--  and it will iterate over it.  The reference will be held until the reference object is
--  finalized.  While doing so, if another task updates the vector, a new vector array will
--  be associated with the vector instance (but this will not change the reader's references).
--
--     R : My_Array.Ref := C.Get;
--
--     R.Iterate (Process'Access);
--     ...
--     R.Iterate (Process'Access);
--
--  In the above example, the two `Iterate` operations will iterate over the same list of
--  elements, even if another task appends an element in the middle.
--
--  Notes:
--    * This package is close to the Java class `java.util.concurrent.CopyOnWriteArrayList`.
--
--    * The package implements voluntarily a very small subset of `Ada.Containers.Vectors`.
--
--    * The implementation does not use the Ada container for performance and size reasons.
--
--    * The `Iterate` and `Reverse_Iterate` operation give a direct access to the element.
generic
   type Element_Type is private;

   with function "=" (Left, Right : in Element_Type) return Boolean is <>;
package Util.Concurrent.Arrays is

   --  The reference to the read-only vector elements.
   type Ref is tagged private;

   --  Returns True if the container is empty.
   function Is_Empty (Container : in Ref) return Boolean;

   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type));

   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type));

   --  Vector of elements.
   type Vector is new Ada.Finalization.Limited_Controlled with private;

   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   function Get (Container : in Vector'Class) return Ref;

   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type);

   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type);

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector);

private

   --  To store the vector elements, we use an array which is allocated dynamically.
   --  The generated code is smaller compared to the use of Ada vectors container.
   type Element_Array is array (Positive range <>) of Element_Type;
   type Element_Array_Access is access all Element_Array;

   Null_Element_Array : constant Element_Array_Access := null;

   type Vector_Record (Len : Positive) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      List        : Element_Array (1 .. Len);
   end record;
   type Vector_Record_Access is access all Vector_Record;

   type Ref is new Ada.Finalization.Controlled with record
      Target : Vector_Record_Access := null;
   end record;

   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   overriding
   procedure Finalize (Obj : in out Ref);

   --  Update the reference counter after an assignment.
   overriding
   procedure Adjust (Obj : in out Ref);

   --  Vector of objects
   protected type Protected_Vector is

      --  Get a readonly reference to the vector.
      function Get return Ref;

      --  Append the element to the vector.
      procedure Append (Item : in Element_Type);

      --  Remove the element from the vector.
      procedure Remove (Item : in Element_Type);

   private
      Elements : Ref;
   end Protected_Vector;

   type Vector is new Ada.Finalization.Limited_Controlled with record
      List : Protected_Vector;
   end record;

end Util.Concurrent.Arrays;

-----------------------------------------------------------------------
--  util-concurrent-arrays -- Concurrent Arrays
--  Copyright (C) 2012, 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.Concurrent.Counters;

--  == Introduction ==
--  The Util.Concurrent.Arrays generic package defines an array which provides a
--  concurrent read only access and a protected exclusive write access.  This implementation
--  is intended to be used in applications that have to frequently iterate over the array
--  content.  Adding or removing elements in the array is assumed to be a not so frequent
--  operation.  Based on these assumptions, updating the array is implemented by
--  using the <tt>copy on write</tt> design pattern.  Read access is provided through a
--  reference object that can be shared by multiple readers.
--
--  == Declaration ==
--  The package must be instantiated using the element type representing the array element.
--
--    package My_Array is new Util.Concurrent.Arrays (Element_Type => Integer);
--
--  == Adding Elements ==
--  The vector instance is declared and elements are added as follows:
--
--     C : My_Array.Vector;
--
--     C.Append (E1);
--
--  == Iterating over the array ==
--  To read and iterate over the vector, a task will get a reference to the vector array
--  and it will iterate over it.  The reference will be held until the reference object is
--  finalized.  While doing so, if another task updates the vector, a new vector array will
--  be associated with the vector instance (but this will not change the reader's references).
--
--     R : My_Array.Ref := C.Get;
--
--     R.Iterate (Process'Access);
--     ...
--     R.Iterate (Process'Access);
--
--  In the above example, the two `Iterate` operations will iterate over the same list of
--  elements, even if another task appends an element in the middle.
--
--  Notes:
--    * This package is close to the Java class `java.util.concurrent.CopyOnWriteArrayList`.
--
--    * The package implements voluntarily a very small subset of `Ada.Containers.Vectors`.
--
--    * The implementation does not use the Ada container for performance and size reasons.
--
--    * The `Iterate` and `Reverse_Iterate` operation give a direct access to the element.
generic
   type Element_Type is private;

   with function "=" (Left, Right : in Element_Type) return Boolean is <>;
package Util.Concurrent.Arrays is

   --  The reference to the read-only vector elements.
   type Ref is tagged private;

   --  Returns True if the container is empty.
   function Is_Empty (Container : in Ref) return Boolean;

   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type));

   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type));

   --  Vector of elements.
   type Vector is new Ada.Finalization.Limited_Controlled with private;

   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   function Get (Container : in Vector'Class) return Ref;

   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type);

   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type);

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector);

private

   --  To store the vector elements, we use an array which is allocated dynamically.
   --  The generated code is smaller compared to the use of Ada vectors container.
   type Element_Array is array (Positive range <>) of Element_Type;
   type Element_Array_Access is access all Element_Array;

   Null_Element_Array : constant Element_Array_Access := null;

   type Vector_Record (Len : Positive) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      List        : Element_Array (1 .. Len);
   end record;
   type Vector_Record_Access is access all Vector_Record;

   type Ref is new Ada.Finalization.Controlled with record
      Target : Vector_Record_Access := null;
   end record;

   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   overriding
   procedure Finalize (Obj : in out Ref);

   --  Update the reference counter after an assignment.
   overriding
   procedure Adjust (Obj : in out Ref);

   --  Vector of objects
   protected type Protected_Vector is

      --  Get a readonly reference to the vector.
      function Get return Ref;

      --  Append the element to the vector.
      procedure Append (Item : in Element_Type);

      --  Remove the element from the vector.
      procedure Remove (Item : in Element_Type);

   private
      Elements : Ref;
   end Protected_Vector;

   type Vector is new Ada.Finalization.Limited_Controlled with record
      List : Protected_Vector;
   end record;

end Util.Concurrent.Arrays;

Update the header

Update the header


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

with EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

end EL.Beans;

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

with EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is interface and Readonly_Bean;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Get the element at the given index.
   function Get_Row (From  : List_Bean;
                     Index : Natural) return EL.Objects.Object is abstract;

end EL.Beans;

Declare the List_Bean to represent lists that can be accessed from the Object


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

with Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

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

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  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 Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

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

with Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

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

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  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 Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER or From.Kind = T_ENTITY_TYPE);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_ENTITY_TYPE =>
            return "entity_type";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

Add T_ENTITY_TYPE in the enumeration

Add T_ENTITY_TYPE in the enumeration