-----------------------------------------------------------------------
-- gen-generator -- Code Generator
-- Copyright (C) 2009 - 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.Directories;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed;
with Ada.Calendar;
with Ada.Environment_Variables;
with Input_Sources.File;
with DOM.Core;
with DOM.Core.Documents;
with DOM.Readers;
with Sax.Readers;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Components.Root;
with ASF.Components.Base;
with ASF.Servlets.Faces;
with Servlet.Core;
with EL.Functions;
with EL.Utils;
with EL.Contexts.Default;
with Gen.Utils;
with Gen.Configs;
with Gen.Model;
with Gen.Model.Enums;
with Gen.Model.Tables;
with Gen.Model.Mappings;
with Gen.Commands.Templates;
with Util.Strings;
with Util.Strings.Vectors;
with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Basic;
with Util.Beans.Objects.Time;
with Util.Systems.Os;
package body Gen.Generator is
use ASF;
use Util.Log;
Log : constant Loggers.Logger := Loggers.Create ("Gen.Generator");
RESULT_DIR : constant String := "generator.output.dir";
Windows : constant Boolean := Util.Systems.Os.Directory_Separator = '\';
function Get_Ada_Type (Type_Name : in UString) return String;
function To_Ada_Type (Value : in UBO.Object;
Param : in UBO.Object) return UBO.Object;
function Indent (Value : UBO.Object) return UBO.Object;
-- EL Function to translate a model type to the key enum value
function To_Key_Enum (Name : UBO.Object) return UBO.Object;
-- EL function to create an Ada identifier from a file name
function To_Ada_Ident (Value : UBO.Object) return UBO.Object;
-- EL function to format an Ada comment
function Comment (Value : in UBO.Object;
Prefix : in UBO.Object) return UBO.Object;
-- EL function to return a singular form of a name
function To_Singular (Value : in UBO.Object) return UBO.Object;
-- Returns a string resulting from replacing in an input string all occurrences of
-- a "Item" string into an "By" substring.
function Replace (Value, Item, By : in UBO.Object)
return UBO.Object;
-- Concat the arguments converted as a string.
function Concat (Arg1, Arg2, Arg3, Arg4 : in UBO.Object)
return UBO.Object;
-- EL function to check if a file exists.
function File_Exists (Path : in UBO.Object) return UBO.Object;
procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
Current_Package : UString;
function Get_Ada_Type (Type_Name : in UString) return String is
Name : constant String := To_String (Type_Name);
Pkg : constant String := To_String (Current_Package);
begin
if Name'Length > Pkg'Length
and then Util.Strings.Starts_With (Name, Pkg)
and then Name (Name'First + Pkg'Length) = '.'
then
return Name (Name'First + Pkg'Length + 1 .. Name'Last);
else
return Name;
end if;
end Get_Ada_Type;
-- ------------------------------
-- EL Function to translate a model type to an Ada implementation type
-- Param values:
-- 0 : Get the type for a record declaration
-- 1 : Get the type for a parameter declaration or a return type
-- 2 : Get the type for the generation of the ADO.Statements.Get procedure name
-- ------------------------------
function To_Ada_Type (Value : in UBO.Object;
Param : in UBO.Object) return UBO.Object is
use Gen.Model.Tables;
use Gen.Model.Mappings;
use Gen.Model;
Column : Column_Definition_Access := null;
Ptr : constant access Util.Beans.Basic.Readonly_Bean'Class
:= UBO.To_Bean (Value);
Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
begin
if Ptr /= null and then Ptr.all in Column_Definition'Class then
Column := Column_Definition'Class (Ptr.all)'Unchecked_Access;
else
Column := null;
end if;
if Column /= null then
Type_Mapping := Column.Get_Type_Mapping;
if Type_Mapping /= null then
if Type_Mapping.Kind = T_DATE and then UBO.To_Integer (Param) = 2 then
return UBO.To_Object (String '("Time"));
elsif Type_Mapping.Kind = T_ENUM then
if Column.Not_Null or else UBO.To_Integer (Param) = 2 then
return UBO.To_Object (Get_Ada_Type (Column.Type_Name));
else
declare
Result : constant UString
:= Gen.Model.Enums.Enum_Definition (Type_Mapping.all).Nullable_Type;
begin
return UBO.To_Object (Get_Ada_Type (Result));
end;
end if;
elsif Type_Mapping.Kind /= T_TABLE then
if Length (Type_Mapping.Target) > 0 then
return UBO.To_Object (Type_Mapping.Target);
else
return UBO.To_Object (Type_Mapping.Name);
end if;
elsif Column.Use_Foreign_Key_Type then
return UBO.To_Object (Type_Mapping.Target);
elsif UBO.To_Integer (Param) = 1 then
return UBO.To_Object (Get_Ada_Type (Type_Mapping.Target) & "_Ref'Class");
else
return UBO.To_Object (Get_Ada_Type (Type_Mapping.Target) & "_Ref");
end if;
elsif Column.Is_Basic_Type then
return UBO.To_Object (Column.Get_Type);
elsif UBO.To_Integer (Param) = 1 then
return UBO.To_Object (Get_Ada_Type (To_UString (Column.Get_Type)) & "_Ref'Class");
else
return UBO.To_Object (Get_Ada_Type (To_UString (Column.Get_Type)) & "_Ref");
end if;
else
return Value;
end if;
end To_Ada_Type;
-- ------------------------------
-- Concat the arguments converted as a string.
-- ------------------------------
function Concat (Arg1, Arg2, Arg3, Arg4 : in UBO.Object)
return UBO.Object is
Result : UString;
begin
if not UBO.Is_Null (Arg1) then
Append (Result, UBO.To_String (Arg1));
end if;
if not UBO.Is_Null (Arg2) then
Append (Result, UBO.To_String (Arg2));
end if;
if not UBO.Is_Null (Arg3) then
Append (Result, UBO.To_String (Arg3));
end if;
if not UBO.Is_Null (Arg4) then
Append (Result, UBO.To_String (Arg4));
end if;
return UBO.To_Object (Result);
end Concat;
KEY_INTEGER_LABEL : constant String := "KEY_INTEGER";
KEY_STRING_LABEL : constant String := "KEY_STRING";
-- ------------------------------
-- EL Function to translate a model type to the key enum value
-- ------------------------------
function To_Key_Enum (Name : UBO.Object) return UBO.Object is
Value : constant String := UBO.To_String (Name);
begin
if Value in "Integer" | "int" | "Identifier" | "ADO.Identifier" then
return UBO.To_Object (KEY_INTEGER_LABEL);
else
return UBO.To_Object (KEY_STRING_LABEL);
end if;
end To_Key_Enum;
-- ------------------------------
-- EL function to indent the code
-- ------------------------------
function Indent (Value : UBO.Object) return UBO.Object is
S : constant String := UBO.To_String (Value);
Result : constant String (S'Range) := (others => ' ');
begin
return UBO.To_Object (Result);
end Indent;
-- ------------------------------
-- EL function to create an Ada identifier from a file name
-- ------------------------------
function To_Ada_Ident (Value : UBO.Object) return UBO.Object is
Name : constant String := UBO.To_String (Value);
Result : UString;
C : Character;
begin
for I in Name'Range loop
C := Name (I);
if C = '-' then
Append (Result, '_');
elsif C in 'a' .. 'z' then
Append (Result, C);
elsif C in 'A' .. 'Z' then
Append (Result, C);
elsif C in '0' .. '9' then
Append (Result, C);
end if;
end loop;
return UBO.To_Object (Result);
end To_Ada_Ident;
-- ------------------------------
-- EL function to return a singular form of a name
-- ------------------------------
function To_Singular (Value : in UBO.Object) return UBO.Object is
Name : constant String := UBO.To_String (Value);
begin
if Name'Length > 1 and then Name (Name'Last) = 's' then
return UBO.To_Object (Name (Name'First .. Name'Last - 1));
else
return Value;
end if;
end To_Singular;
-- ------------------------------
-- Returns a string resulting from replacing in an input string all occurrences of
-- a "Item" string into an "By" substring.
-- ------------------------------
function Replace (Value, Item, By : in UBO.Object)
return UBO.Object is
Content : constant String := UBO.To_String (Value);
Pattern : constant String := UBO.To_String (Item);
Token : constant String := UBO.To_String (By);
Last : Natural := Content'First;
Result : UString;
Pos : Natural;
begin
if Pattern'Length = 0 then
return Value;
end if;
while Last <= Content'Last loop
Pos := Ada.Strings.Fixed.Index (Content, Pattern, Last);
if Pos = 0 then
Append (Result, Content (Last .. Content'Last));
exit;
else
if Last < Pos then
Append (Result, Content (Last .. Pos - 1));
end if;
Append (Result, Token);
end if;
Last := Pos + Pattern'Length;
end loop;
return UBO.To_Object (Result);
end Replace;
-- ------------------------------
-- EL function to format an Ada comment
-- ------------------------------
function Comment (Value : in UBO.Object;
Prefix : in UBO.Object) return UBO.Object is
START_POS : constant Natural := 8;
Comment : constant String := Ada.Strings.Fixed.Trim (UBO.To_String (Value),
Ada.Strings.Both);
Result : UString;
C : Character;
Pos : Natural := START_POS;
begin
for I in Comment'Range loop
C := Comment (I);
if Pos > START_POS then
if C = ASCII.LF then
Pos := START_POS;
else
Append (Result, C);
Pos := Pos + 1;
end if;
elsif C /= ' ' and then C /= ASCII.LF then
if Length (Result) > 0 then
Append (Result, ASCII.LF);
Append (Result, " -- ");
else
Append (Result, " ");
if not UBO.Is_Null (Prefix)
and then not UBO.Is_Empty (Prefix)
then
Append (Result, UBO.To_String (Prefix));
end if;
end if;
Append (Result, C);
Pos := Pos + 1;
end if;
end loop;
Append (Result, ASCII.LF);
return UBO.To_Object (Result);
end Comment;
-- ------------------------------
-- EL function to check if a file exists.
-- ------------------------------
function File_Exists (Path : in UBO.Object) return UBO.Object is
P : constant String := UBO.To_String (Path);
begin
return UBO.To_Object (Ada.Directories.Exists (P));
end File_Exists;
-- ------------------------------
-- Register the generator EL functions
-- ------------------------------
procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
begin
Mapper.Set_Function (Name => "adaIdent",
Namespace => G_URI,
Func => To_Ada_Ident'Access);
Mapper.Set_Function (Name => "adaType",
Namespace => G_URI,
Func => To_Ada_Type'Access);
Mapper.Set_Function (Name => "indent",
Namespace => G_URI,
Func => Indent'Access);
Mapper.Set_Function (Name => "keyEnum",
Namespace => G_URI,
Func => To_Key_Enum'Access);
Mapper.Set_Function (Name => "comment",
Namespace => G_URI,
Func => Comment'Access);
Mapper.Set_Function (Name => "singular",
Namespace => G_URI,
Func => To_Singular'Access);
Mapper.Set_Function (Name => "replace",
Namespace => G_URI,
Func => Replace'Access);
Mapper.Set_Function (Name => "exists",
Namespace => G_URI,
Func => File_Exists'Access);
Mapper.Set_Function (Name => "concat",
Namespace => G_URI,
Func => Concat'Access);
end Set_Functions;
-- ------------------------------
-- Set the global configuration identified by the name by pre-pending the
-- environtment variable if it is defined.
-- ------------------------------
procedure Set_Configuration (H : in out Handler;
Name : in String;
Env_Name : in String) is
begin
if not Ada.Environment_Variables.Exists (Env_Name) then
return;
end if;
declare
Value : String
:= Ada.Environment_Variables.Value (Env_Name);
begin
if not Windows then
for I in Value'Range loop
if Value (I) = ':' then
Value (I) := ';';
end if;
end loop;
end if;
if H.Conf.Exists (Name) then
H.Conf.Set (Name, String '(Value & ";" & H.Conf.Get (Name)));
else
H.Conf.Set (Name, Value);
end if;
end;
end Set_Configuration;
-- ------------------------------
-- Initialize the generator
-- ------------------------------
procedure Initialize (H : in out Handler;
Config_Dir : in UString;
Debug : in Boolean) is
use Ada.Directories;
procedure Register_Funcs is
new ASF.Applications.Main.Register_Functions (Set_Functions);
Dir : constant String := To_String (Config_Dir);
Factory : ASF.Applications.Main.Application_Factory;
Path : constant String := Compose (Dir, "generator.properties");
Context : EL.Contexts.Default.Default_Context;
Props : Util.Properties.Manager;
begin
Log.Debug ("Initialize dynamo with {0}", Path);
begin
Props.Load_Properties (Path => Path);
exception
when Ada.IO_Exceptions.Name_Error =>
H.Error ("Cannot load configuration file {0}", Path);
end;
H.Conf.Set (ASF.Applications.VIEW_DIR, Compose (Dir, "templates"));
H.Conf.Set (ASF.Applications.VIEW_IGNORE_WHITE_SPACES, "false");
H.Conf.Set (ASF.Applications.VIEW_ESCAPE_UNKNOWN_TAGS, "false");
H.Conf.Set (ASF.Applications.VIEW_IGNORE_EMPTY_LINES, "true");
H.Conf.Set (ASF.Applications.VIEW_FILE_EXT, "");
H.Conf.Set ("ado.queries.paths", Compose (Dir, "db"));
if Debug then
Log.Info ("Setting debug mode");
H.Conf.Set (Gen.Configs.GEN_DEBUG_ENABLE, "1");
end if;
Props.Set ("generator_config_dir", Dir);
EL.Utils.Expand (Source => Props, Into => H.Conf, Context => Context);
H.Set_Configuration (Gen.Configs.GEN_DYNAMO_SEARCH_DIRS,
Gen.Configs.ENV_DYNAMO_SEARCH_PATH);
H.Set_Configuration (Gen.Configs.GEN_UML_DIR,
Gen.Configs.ENV_DYNAMO_UML_PATH);
H.Set_Configuration ("bundle.dir",
Gen.Configs.ENV_DYNAMO_BUNDLE_PATH);
H.Initialize (H.Conf, Factory);
H.Config_Dir := To_UString (Dir);
H.Output_Dir := To_UString (H.Conf.Get (RESULT_DIR, "./"));
Register_Funcs (H);
H.File := new UBO.Object;
H.Mode := new UBO.Object;
H.Ignore := new UBO.Object;
H.Servlet := new ASF.Servlets.Faces.Faces_Servlet;
H.Add_Servlet (Name => "file", Server => H.Servlet);
H.Add_Mapping ("*.xhtml", "file");
H.Start;
begin
Gen.Commands.Templates.Read_Commands (H);
exception
when Ada.IO_Exceptions.Name_Error =>
H.Error ("Cannot read external commands");
end;
end Initialize;
-- ------------------------------
-- Get the configuration properties.
-- ------------------------------
function Get_Properties (H : in Handler) return Util.Properties.Manager is
begin
return Util.Properties.Manager (H.Conf);
end Get_Properties;
-- ------------------------------
-- Set the directory where template files are stored.
-- ------------------------------
procedure Set_Template_Directory (H : in out Handler;
Path : in UString) is
begin
H.Conf.Set (ASF.Applications.VIEW_DIR, Path);
end Set_Template_Directory;
-- ------------------------------
-- Set the directory where results files are generated.
-- ------------------------------
procedure Set_Result_Directory (H : in out Handler;
Path : in String) is
begin
H.Conf.Set (RESULT_DIR, Path);
H.Output_Dir := To_UString (Path);
end Set_Result_Directory;
-- ------------------------------
-- Get the result directory path.
-- ------------------------------
overriding
function Get_Result_Directory (H : in Handler) return String is
begin
return To_String (H.Output_Dir);
end Get_Result_Directory;
-- ------------------------------
-- Get the project plugin directory path.
-- ------------------------------
function Get_Plugin_Directory (H : in Handler) return String is
begin
return Util.Files.Compose (H.Get_Result_Directory, H.Project.Get_Module_Dir);
end Get_Plugin_Directory;
-- ------------------------------
-- Get the config directory path.
-- ------------------------------
overriding
function Get_Config_Directory (H : in Handler) return String is
begin
return To_String (H.Config_Dir);
end Get_Config_Directory;
-- ------------------------------
-- Get the dynamo installation directory path.
-- ------------------------------
function Get_Install_Directory (H : in Handler) return String is
begin
return Ada.Directories.Containing_Directory (To_String (H.Config_Dir));
end Get_Install_Directory;
-- ------------------------------
-- Get the exit status
-- Returns 0 if the generation was successful
-- Returns 1 if there was a generation error
-- ------------------------------
function Get_Status (H : in Handler) return Ada.Command_Line.Exit_Status is
begin
return H.Status;
end Get_Status;
-- ------------------------------
-- Get the configuration parameter.
-- ------------------------------
overriding
function Get_Parameter (H : in Handler;
Name : in String;
Default : in String := "") return String is
begin
if Util.Strings.Starts_With (Name, "dynamo.") then
return H.Get_Project_Property (Name (Name'First + 7 .. Name'Last), Default);
end if;
return H.Conf.Get (Name, Default);
end Get_Parameter;
-- ------------------------------
-- Get the configuration parameter.
-- ------------------------------
overriding
function Get_Parameter (H : in Handler;
Name : in String;
Default : in Boolean := False) return Boolean is
begin
if not H.Conf.Exists (Name) then
return Default;
else
declare
V : constant String := H.Conf.Get (Name);
begin
return V in "1" | "true" | "yes";
end;
end if;
end Get_Parameter;
-- ------------------------------
-- Set the force-save file mode. When False, if the generated file exists already,
-- an error message is reported.
-- ------------------------------
procedure Set_Force_Save (H : in out Handler;
To : in Boolean) is
begin
H.Force_Save := To;
end Set_Force_Save;
-- ------------------------------
-- Set the project name.
-- ------------------------------
procedure Set_Project_Name (H : in out Handler;
Name : in String) is
Pos : constant Natural := Util.Strings.Index (Name, '-');
begin
if not Gen.Utils.Is_Valid_Name (Name)
and then (Pos <= Name'First
or else not Gen.Utils.Is_Valid_Name (Name (Name'First .. Pos - 1)))
then
H.Error ("The project name should be a valid Ada identifier ([A-Za-z][A-Za-z0-9_]*).");
raise Fatal_Error with "Invalid project name: " & Name;
end if;
H.Project.Set_Name (Name);
H.Set_Global ("projectName", Name);
if Pos > Name'First then
H.Set_Global ("projectAdaName", Name (Name'First .. Pos - 1));
else
H.Set_Global ("projectAdaName", Name);
end if;
end Set_Project_Name;
-- ------------------------------
-- Get the project name.
-- ------------------------------
function Get_Project_Name (H : in Handler) return String is
begin
return H.Project.Get_Project_Name;
end Get_Project_Name;
-- ------------------------------
-- Set the project property.
-- ------------------------------
procedure Set_Project_Property (H : in out Handler;
Name : in String;
Value : in String) is
begin
Log.Debug ("Set property {0} to {1}", Name, Value);
H.Project.Props.Set (Name, Value);
H.Project.Update_From_Properties;
end Set_Project_Property;
-- ------------------------------
-- Get the project property identified by the given name. If the project property
-- does not exist, returns the default value. Project properties are loaded
-- by Read_Project.
-- ------------------------------
function Get_Project_Property (H : in Handler;
Name : in String;
Default : in String := "") return String is
begin
return H.Project.Props.Get (Name, Default);
end Get_Project_Property;
-- ------------------------------
-- Save the project description and parameters.
-- ------------------------------
procedure Save_Project (H : in out Handler) is
Path : constant String := Ada.Directories.Compose (H.Get_Result_Directory, "dynamo.xml");
begin
-- Set the 'search_dirs' property only if we did a recursive scan of GNAT project files.
-- Otherwise we don't know which Dynamo module or library is used.
if H.Project.Recursive_Scan then
-- if H.Get_Project_Property ("search_dirs", ".") = "." then
-- H.Read_Project ("dynamo.xml", True);
-- end if;
-- Do not update the search_dirs if the project is a plugin.
-- This is only meaningful in the final project.
if not H.Project.Is_Plugin then
H.Set_Project_Property ("search_dirs", H.Get_Search_Directories);
end if;
end if;
H.Project.Save (Path);
end Save_Project;
-- ------------------------------
-- Get the path of the last generated file.
-- ------------------------------
function Get_Generated_File (H : in Handler) return String is
begin
return UBO.To_String (H.File.all);
end Get_Generated_File;
-- ------------------------------
-- Report an error and set the exit status accordingly
-- ------------------------------
overriding
procedure Error (H : in out Handler;
Message : in String;
Arg1 : in String;
Arg2 : in String := "") is
begin
Log.Error ("error: " & Message, Arg1, Arg2);
H.Status := 1;
end Error;
overriding
procedure Error (H : in out Handler;
Message : in String) is
begin
Log.Error ("error: " & Message);
H.Status := 1;
end Error;
-- ------------------------------
-- Report an info message.
-- ------------------------------
procedure Info (H : in out Handler;
Message : in String;
Arg1 : in String := "";
Arg2 : in String := "";
Arg3 : in String := "") is
pragma Unreferenced (H);
begin
Log.Info (Message, Arg1, Arg2, Arg3);
end Info;
-- ------------------------------
-- Read the XML project file. When Recursive is set, read the GNAT project
-- files used by the main project and load all the dynamo.xml files defined
-- by these project.
-- ------------------------------
procedure Read_Project (H : in out Handler;
File : in String;
Recursive : in Boolean := False) is
Dir : constant String := H.Get_Install_Directory;
Search_Dir : constant String := H.Get_Parameter (Gen.Configs.GEN_DYNAMO_SEARCH_DIRS, ".");
begin
H.Project.Install_Dir := To_UString (Dir & ";" & Search_Dir);
H.Project.Read_Project (File => File,
Config => H.Conf,
Recursive => Recursive);
H.Set_Project_Name (H.Get_Project_Name);
end Read_Project;
-- ------------------------------
-- Read the XML package file
-- ------------------------------
procedure Read_Package (H : in out Handler;
File : in String) is
Read : Input_Sources.File.File_Input;
My_Tree_Reader : DOM.Readers.Tree_Reader;
Name_Start : Natural;
begin
Log.Info ("Reading package file '{0}'", File);
-- Base file name should be used as the public Id
Name_Start := File'Last;
while Name_Start >= File'First and then File (Name_Start) /= '/' loop
Name_Start := Name_Start - 1;
end loop;
Input_Sources.File.Open (File, Read);
-- Full name is used as the system id
Input_Sources.File.Set_System_Id (Read, File);
Input_Sources.File.Set_Public_Id (Read, File (Name_Start + 1 .. File'Last));
DOM.Readers.Set_Feature (My_Tree_Reader, Sax.Readers.Validation_Feature, False);
DOM.Readers.Parse (My_Tree_Reader, Read);
Input_Sources.File.Close (Read);
declare
Doc : constant DOM.Core.Document := DOM.Readers.Get_Tree (My_Tree_Reader);
Root : constant DOM.Core.Element := DOM.Core.Documents.Get_Element (Doc);
begin
H.Distrib.Initialize (Path => File, Model => H.Model, Node => Root, Context => H);
end;
exception
when Ada.IO_Exceptions.Name_Error =>
H.Error ("Package file {0} does not exist", File);
end Read_Package;
-- ------------------------------
-- Read the model mapping types and initialize the hibernate artifact.
-- ------------------------------
procedure Read_Mappings (H : in out Handler) is
procedure Read_Mapping (Name : in String;
Default : in String);
Dir : constant String := H.Get_Config_Directory;
procedure Read_Mapping (Name : in String;
Default : in String) is
Mapping : constant String := H.Get_Parameter (Name, Default);
begin
H.Read_Model (File => Util.Files.Compose (Dir, Mapping), Silent => True);
end Read_Mapping;
begin
-- Read the type mappings for Ada, MySQL, Postgresql and SQLite.
H.Type_Mapping_Loaded := True;
Read_Mapping ("generator.mapping.ada", "AdaMappings.xml");
Read_Mapping ("generator.mapping.mysql", "MySQLMappings.xml");
Read_Mapping ("generator.mapping.postgresql", "PostgresqlMappings.xml");
Read_Mapping ("generator.mapping.sqlite", "SQLiteMappings.xml");
end Read_Mappings;
-- ------------------------------
-- Read the XML model file
-- ------------------------------
procedure Read_Model (H : in out Handler;
File : in String;
Silent : in Boolean) is
Read : Input_Sources.File.File_Input;
My_Tree_Reader : DOM.Readers.Tree_Reader;
Name_Start : Natural;
Ext : constant String := Ada.Directories.Extension (File);
begin
-- Before loading a model file, we should know the type mappings.
-- Load them first if needed.
if not H.Type_Mapping_Loaded then
H.Read_Mappings;
end if;
Gen.Model.Mappings.Set_Mapping_Name (Gen.Model.Mappings.ADA_MAPPING);
if Silent then
Log.Debug ("Reading model file '{0}'", File);
else
Log.Info ("Reading model file '{0}'", File);
end if;
if Ext in "xmi" | "XMI" | "zargo" then
H.XMI.Read_Model (File, "", H);
return;
elsif Ext in "yaml" | "YAML" then
H.Yaml.Read_Model (File, H.Model, H);
return;
end if;
-- Base file name should be used as the public Id
Name_Start := File'Last;
while Name_Start >= File'First and then File (Name_Start) /= '/' loop
Name_Start := Name_Start - 1;
end loop;
Input_Sources.File.Open (File, Read);
-- Full name is used as the system id
Input_Sources.File.Set_System_Id (Read, File);
Input_Sources.File.Set_Public_Id (Read, File (Name_Start + 1 .. File'Last));
DOM.Readers.Set_Feature (My_Tree_Reader, Sax.Readers.Validation_Feature, False);
DOM.Readers.Parse (My_Tree_Reader, Read);
Input_Sources.File.Close (Read);
declare
Doc : constant DOM.Core.Document := DOM.Readers.Get_Tree (My_Tree_Reader);
Root : constant DOM.Core.Element := DOM.Core.Documents.Get_Element (Doc);
begin
H.Mappings.Initialize (Path => File, Model => H.Model, Node => Root, Context => H);
H.Hibernate.Initialize (Path => File, Model => H.Model, Node => Root, Context => H);
H.Query.Initialize (Path => File, Model => H.Model, Node => Root, Context => H);
H.Yaml.Initialize (Path => File, Model => H.Model, Node => Root, Context => H);
end;
-- DOM.Readers.Free (My_Tree_Reader);
exception
when Ada.IO_Exceptions.Name_Error =>
H.Error ("Model file {0} does not exist", File);
end Read_Model;
-- ------------------------------
-- Read the model and query files stored in the application directory db.
-- ------------------------------
procedure Read_Models (H : in out Handler;
Dirname : in String) is
use Ada.Directories;
Path : constant String := Dirname;
Name : constant String := Ada.Directories.Base_Name (Path);
Filter : constant Filter_Type := (Ordinary_File => True, others => False);
Search : Search_Type;
Ent : Directory_Entry_Type;
Files : Util.Strings.Vectors.Vector;
package Sort_Names is
new Util.Strings.Vectors.Generic_Sorting;
begin
Log.Info ("Reading model file stored in '{0}'", Path);
-- No argument specified, look at the model files in the db directory.
if Exists (Path) then
if Name = "regtests" then
H.Model.Set_Dirname ("regtests", Path);
elsif Name = "samples" then
H.Model.Set_Dirname ("samples", Path);
else
H.Model.Set_Dirname ("src", Path);
end if;
Start_Search (Search, Directory => Path, Pattern => "*.xm[il]", Filter => Filter);
-- Collect the files in the vector array.
while More_Entries (Search) loop
Get_Next_Entry (Search, Ent);
Files.Append (Full_Name (Ent));
end loop;
Start_Search (Search, Directory => Path, Pattern => "*.yaml", Filter => Filter);
-- Collect the files in the vector array.
while More_Entries (Search) loop
Get_Next_Entry (Search, Ent);
Files.Append (Full_Name (Ent));
end loop;
Start_Search (Search, Directory => Path, Pattern => "*.zargo", Filter => Filter);
-- Collect the files in the vector array.
while More_Entries (Search) loop
Get_Next_Entry (Search, Ent);
Files.Append (Full_Name (Ent));
end loop;
-- Sort the files on their name to get a reproducible generation of some database
-- models.
Sort_Names.Sort (Files);
-- Read the model files
declare
Iter : Util.Strings.Vectors.Cursor := Files.First;
begin
while Util.Strings.Vectors.Has_Element (Iter) loop
H.Read_Model (File => Util.Strings.Vectors.Element (Iter),
Silent => False);
Util.Strings.Vectors.Next (Iter);
end loop;
end;
end if;
end Read_Models;
-- ------------------------------
-- Execute the lifecycle phases on the faces context.
-- ------------------------------
overriding
procedure Execute_Lifecycle (App : in Handler;
Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
begin
ASF.Applications.Main.Application (App).Execute_Lifecycle (Context);
declare
View : constant Components.Root.UIViewRoot := Context.Get_View_Root;
Root : constant access Components.Base.UIComponent'Class
:= Components.Root.Get_Root (View);
begin
if Root /= null then
App.File.all := Root.Get_Attribute (Context, "file");
App.Mode.all := Root.Get_Attribute (Context, "mode");
App.Ignore.all := Root.Get_Attribute (Context, "ignore");
end if;
end;
end Execute_Lifecycle;
-- ------------------------------
-- Prepare the model by checking, verifying and initializing it after it is completely known.
-- ------------------------------
procedure Prepare (H : in out Handler) is
begin
if H.XMI.Is_Initialized then
H.XMI.Prepare (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.Yaml.Is_Initialized then
H.Yaml.Prepare (Model => H.Model, Project => H.Project, Context => H);
end if;
H.Model.Prepare;
if H.Hibernate.Is_Initialized then
H.Hibernate.Prepare (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.Query.Is_Initialized then
H.Query.Prepare (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.Distrib.Is_Initialized then
H.Distrib.Prepare (Model => H.Model, Project => H.Project, Context => H);
end if;
H.Model.Validate (H);
end Prepare;
-- ------------------------------
-- Finish the generation. Some artifacts could generate other files that take into
-- account files generated previously.
-- ------------------------------
procedure Finish (H : in out Handler) is
begin
if H.Hibernate.Is_Initialized then
H.Hibernate.Finish (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.Query.Is_Initialized then
H.Query.Finish (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.Distrib.Is_Initialized then
H.Distrib.Finish (Model => H.Model, Project => H.Project, Context => H);
end if;
if H.XMI.Is_Initialized then
H.XMI.Finish (Model => H.Model, Project => H.Project, Context => H);
end if;
end Finish;
-- ------------------------------
-- Tell the generator to activate the generation of the given template name.
-- The name is a property name that must be defined in generator.properties to
-- indicate the template file. Several artifacts can trigger the generation
-- of a given template. The template is generated only once.
-- ------------------------------
overriding
procedure Add_Generation (H : in out Handler;
Name : in String;
Mode : in Gen.Artifacts.Iteration_Mode;
Mapping : in String) is
Value : constant String := H.Conf.Get (Name, "");
begin
Log.Debug ("Adding template {0} to the generation", Name);
if Value'Length = 0 then
H.Error ("Template '{0}' is not defined.", Name);
else
H.Templates.Include (To_UString (Value),
Template_Context '(Mode, To_UString (Mapping)));
end if;
end Add_Generation;
-- ------------------------------
-- Enable the generation of the Ada package given by the name. By default all the Ada
-- packages found in the model are generated. When called, this enables the generation
-- only for the Ada packages registered here.
-- ------------------------------
procedure Enable_Package_Generation (H : in out Handler;
Name : in String) is
begin
H.Model.Enable_Package_Generation (Name);
end Enable_Package_Generation;
-- ------------------------------
-- Save the content generated by the template generator.
-- ------------------------------
procedure Save_Content (H : in out Handler;
File : in String;
Content : in UString) is
Dir : constant String := To_String (H.Output_Dir);
Mode : constant String := UBO.To_String (H.Mode.all);
Path : constant String := Util.Files.Compose (Dir, File);
Exists : constant Boolean := Ada.Directories.Exists (Path);
Old_Content : UString;
begin
if Exists and then Mode = "once" then
Log.Info ("File {0} exists, generation skipped.", Path);
elsif Exists and then not (H.Force_Save or else Mode = "force") then
H.Error ("Cannot generate file: '{0}' exists already.", Path);
elsif not UBO.Is_Null (H.File.all) and
then not UBO.To_Boolean (H.Ignore.all)
then
if Length (Content) = 0 and then Mode = "remove-empty" then
Log.Debug ("File {0} skipped because it is empty", Path);
else
Log.Info ("Generating file '{0}'", Path);
if Exists then
Util.Files.Read_File (Path => Path,
Into => Old_Content,
Max_Size => Natural'Last);
end if;
if not Exists or else Content /= Old_Content then
Util.Files.Write_File (Path => Path, Content => Content);
end if;
end if;
end if;
end Save_Content;
-- ------------------------------
-- Generate the code using the template file
-- ------------------------------
procedure Generate (H : in out Handler;
File : in String;
Model : in Gen.Model.Definition_Access;
Save : not null access procedure (H : in out Handler;
File : in String;
Content : in UString)) is
Req : ASF.Requests.Mockup.Request;
Reply : aliased ASF.Responses.Mockup.Response;
Ptr : constant Util.Beans.Basic.Readonly_Bean_Access := Model.all'Unchecked_Access;
Bean : constant UBO.Object := UBO.To_Object (Ptr, UBO.STATIC);
Model_Ptr : constant Util.Beans.Basic.Readonly_Bean_Access := H.Model'Unchecked_Access;
Model_Bean : constant UBO.Object := UBO.To_Object (Model_Ptr, UBO.STATIC);
Prj_Ptr : constant Util.Beans.Basic.Readonly_Bean_Access := H.Project'Unchecked_Access;
Prj_Bean : constant UBO.Object := UBO.To_Object (Prj_Ptr, UBO.STATIC);
Dispatcher : constant ASF.Servlets.Request_Dispatcher := H.Get_Request_Dispatcher (File);
begin
Log.Debug ("With template '{0}'", File);
Current_Package := To_UString (Model.Get_Name);
Req.Set_Method ("GET");
Req.Set_Attribute (Name => "project", Value => Prj_Bean);
Req.Set_Attribute (Name => "package", Value => Bean);
Req.Set_Attribute (Name => "model", Value => Model_Bean);
Req.Set_Attribute (Name => "genRevision", Value => UBO.To_Object (Configs.VERSION));
Req.Set_Attribute (Name => "genURL", Value => UBO.To_Object (Configs.GIT_URL));
Req.Set_Attribute (Name => "date",
Value => UBO.Time.To_Object (Ada.Calendar.Clock));
Servlet.Core.Forward (Dispatcher, Req, Reply);
declare
Content : UString;
File : constant String := UBO.To_String (H.File.all);
begin
Reply.Read_Content (Content);
Save (H, File, Content);
end;
end Generate;
-- ------------------------------
-- Generate the code using the template file
-- ------------------------------
procedure Generate (H : in out Handler;
Mode : in Iteration_Mode;
File : in String;
Save : not null access
procedure (H : in out Handler;
File : in String;
Content : in UString)) is
begin
Log.Debug ("Generating with template {0} in mode {1}",
File, Iteration_Mode'Image (Mode));
case Mode is
when ITERATION_PACKAGE =>
declare
Pos : Gen.Model.Packages.Package_Cursor := H.Model.First;
begin
while Gen.Model.Packages.Has_Element (Pos) loop
declare
P : constant Gen.Model.Packages.Package_Definition_Access
:= Gen.Model.Packages.Element (Pos);
Name : constant String := P.Get_Name;
begin
if H.Model.Is_Generation_Enabled (Name) then
Log.Debug (" Generate for package {0}", Name);
H.Generate (File, Gen.Model.Definition_Access (P), Save);
else
Log.Debug ("Package {0} not generated", Name);
end if;
end;
Gen.Model.Packages.Next (Pos);
end loop;
end;
when ITERATION_TABLE =>
H.Generate (File, H.Model'Unchecked_Access, Save);
end case;
end Generate;
-- ------------------------------
-- Generate all the code for the templates activated through Add_Generation.
-- ------------------------------
procedure Generate_All (H : in out Handler) is
Iter : Template_Map.Cursor := H.Templates.First;
begin
Log.Debug ("Generating the files {0}",
Ada.Containers.Count_Type'Image (H.Templates.Length));
while Template_Map.Has_Element (Iter) loop
declare
T : constant Template_Context := Template_Map.Element (Iter);
begin
Gen.Model.Mappings.Set_Mapping_Name (To_String (T.Mapping));
H.Generate (File => To_String (Template_Map.Key (Iter)),
Mode => T.Mode,
Save => Save_Content'Access);
end;
Template_Map.Next (Iter);
end loop;
end Generate_All;
-- ------------------------------
-- Generate all the code generation files stored in the directory
-- ------------------------------
procedure Generate_All (H : in out Handler;
Mode : in Iteration_Mode;
Name : in String) is
use Ada.Directories;
Search : Search_Type;
Filter : constant Filter_Type := (Ordinary_File => True, others => False);
Dir_Filter : constant Filter_Type := (Directory => True, others => False);
Ent : Directory_Entry_Type;
Dir : constant String := H.Conf.Get (ASF.Applications.VIEW_DIR);
Path : constant String := Util.Files.Compose (Dir, Name);
Base_Dir : constant UString := H.Output_Dir;
begin
if Kind (Path) /= Directory then
Ada.Text_IO.Put_Line ("Cannot read model directory: " & Path);
end if;
Start_Search (Search, Directory => Path, Pattern => "*", Filter => Filter);
while More_Entries (Search) loop
Get_Next_Entry (Search, Ent);
declare
Base_Name : constant String := Simple_Name (Ent);
File_Path : constant String := Full_Name (Ent);
Ext : constant String := Extension (Base_Name);
Target : constant String := Compose (To_String (Base_Dir), Base_Name);
Content : UString;
begin
if Ext = "xhtml" then
H.Generate (Mode, File_Path, Save_Content'Access);
elsif Util.Strings.Index (Base_Name, '~') = 0 then
if Ada.Directories.Exists (Target) and then not H.Force_Save then
H.Error ("Cannot copy file: '{0}' exists already.", Target);
else
Util.Files.Read_File (Path => File_Path, Into => Content);
Util.Files.Write_File (Path => Target,
Content => Content);
end if;
end if;
end;
end loop;
Start_Search (Search, Directory => Path, Pattern => "*", Filter => Dir_Filter);
while More_Entries (Search) loop
Get_Next_Entry (Search, Ent);
declare
Dir_Name : constant String := Simple_Name (Ent);
Dir : constant String := Compose (To_String (Base_Dir), Dir_Name);
begin
if not (Dir_Name in "." | ".." | ".svn") then
H.Output_Dir := To_UString (Dir);
if not Ada.Directories.Exists (Dir) then
Ada.Directories.Create_Directory (Dir);
end if;
H.Generate_All (Mode, Compose (Name, Dir_Name));
end if;
end;
end loop;
H.Output_Dir := Base_Dir;
exception
when E : Ada.IO_Exceptions.Name_Error =>
H.Error ("Template directory {0} does not exist", Path);
Log.Info ("Exception: {0}", Util.Log.Loggers.Traceback (E));
end Generate_All;
-- ------------------------------
-- Update the project model through the Process procedure.
-- ------------------------------
procedure Update_Project (H : in out Handler;
Process : not null access
procedure (P : in out Model.Projects.Root_Project_Definition)) is
begin
Process (H.Project);
end Update_Project;
-- ------------------------------
-- Scan the dynamo directories and execute the Process procedure with the
-- directory path.
-- ------------------------------
overriding
procedure Scan_Directories (H : in Handler;
Process : not null access
procedure (Dir : in String)) is
Iter : Gen.Utils.String_List.Cursor := H.Project.Dynamo_Files.First;
begin
while Gen.Utils.String_List.Has_Element (Iter) loop
declare
use type Gen.Model.Projects.Project_Definition_Access;
Name : constant String := Gen.Utils.String_List.Element (Iter);
Prj : constant Gen.Model.Projects.Project_Definition_Access
:= H.Project.Find_Project (Name);
begin
if Prj /= null then
Process (Prj.Get_Base_Dir);
end if;
end;
Gen.Utils.String_List.Next (Iter);
end loop;
end Scan_Directories;
-- ------------------------------
-- Return the search directories that the AWA application can use to find files.
-- The search directories is built by using the project dependencies.
-- ------------------------------
function Get_Search_Directories (H : in Handler) return String is
Current_Dir : constant String := Ada.Directories.Current_Directory;
Iter : Gen.Utils.String_List.Cursor := H.Project.Dynamo_Files.Last;
Dirs : UString;
begin
while Gen.Utils.String_List.Has_Element (Iter) loop
declare
use type Gen.Model.Projects.Project_Definition_Access;
Name : constant String := Gen.Utils.String_List.Element (Iter);
Prj : constant Gen.Model.Projects.Project_Definition_Access
:= H.Project.Find_Project (Name);
begin
if Prj /= null then
if Length (Dirs) > 0 then
Append (Dirs, ";");
end if;
Append (Dirs, Util.Files.Get_Relative_Path (Current_Dir, Prj.Get_Base_Dir));
end if;
end;
Gen.Utils.String_List.Previous (Iter);
end loop;
return To_String (Dirs);
end Get_Search_Directories;
end Gen.Generator;