----------------------------------------------------------------------- -- gen-model-packages -- Packages holding model, query representation -- 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.Strings; with Ada.Strings.Maps; with Gen.Utils; with Gen.Model.Enums; with Gen.Model.Stypes; with Gen.Model.Tables; with Gen.Model.Queries; with Gen.Model.Beans; with Gen.Model.Operations; with Util.Strings; with Util.Strings.Transforms; with Util.Log.Loggers; package body Gen.Model.Packages is use Ada.Strings.Unbounded; Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Packages"); -- ------------------------------ -- Get the value identified by the name. -- If the name cannot be found, the method should return the Null object. -- ------------------------------ overriding function Get_Value (From : in Package_Definition; Name : in String) return UBO.Object is begin if Name = "name" then return UBO.To_Object (From.Name); elsif Name = "package" then return UBO.To_Object (From.Base_Name); elsif Name = "tables" then return From.Tables_Bean; elsif Name = "enums" then return From.Enums_Bean; elsif Name = "types" then return From.Stypes_Bean; elsif Name = "queries" then return From.Queries_Bean; elsif Name = "beans" then return From.Beans_Bean; elsif Name = "usedSpecTypes" then return From.Used_Spec; elsif Name = "usedBodyTypes" then return From.Used_Body; elsif Name = "useCalendarTime" then return UBO.To_Object (From.Uses_Calendar_Time); else return Definition (From).Get_Value (Name); end if; end Get_Value; -- ------------------------------ -- Find the type identified by the name. -- ------------------------------ function Find_Type (From : in Package_Definition; Name : in UString) return Gen.Model.Mappings.Mapping_Definition_Access is Pos : Mappings.Cursor; begin if Index (Name, ".") > 0 then Pos := From.Types.Find (Name); if not Mappings.Mapping_Maps.Has_Element (Pos) then return From.Model.Find_Type (Name); end if; else Pos := From.Types.Find (From.Name & "." & Name); end if; if Mappings.Mapping_Maps.Has_Element (Pos) then return Mappings.Mapping_Maps.Element (Pos); else return null; end if; end Find_Type; -- ------------------------------ -- Get the model which contains all the package definitions. -- ------------------------------ function Get_Model (From : in Package_Definition) return Model_Definition_Access is begin return From.Model; end Get_Model; -- ------------------------------ -- Returns True if the package is a pre-defined package and must not be generated. -- ------------------------------ function Is_Predefined (From : in Package_Definition) return Boolean is begin return From.Is_Predefined; end Is_Predefined; -- ------------------------------ -- Set the package as a pre-defined package. -- ------------------------------ procedure Set_Predefined (From : in out Package_Definition) is begin From.Is_Predefined := True; end Set_Predefined; -- ------------------------------ -- Register the declaration of the given enum in the model. -- ------------------------------ procedure Register_Enum (O : in out Model_Definition; Enum : access Gen.Model.Enums.Enum_Definition'Class) is Name : constant String := Enum.Get_Name; begin Log.Info ("Registering enum {0}", Name); O.Register_Package (Enum.Pkg_Name, Enum.Package_Def); if Enum.Package_Def.Enums.Find (Name) /= null then raise Name_Exist with "Enum '" & Name & "' already defined"; end if; Enum.Package_Def.Enums.Append (Enum.all'Access); Enum.Package_Def.Types.Include (Enum.Name, Enum.all'Access); O.Enums.Append (Enum.all'Access); Gen.Model.Mappings.Register_Type (Enum.Get_Name, Enum.all'Access, Gen.Model.Mappings.T_ENUM); end Register_Enum; -- ------------------------------ -- Register the declaration of the given data type in the model. -- ------------------------------ procedure Register_Stype (O : in out Model_Definition; Stype : access Gen.Model.Stypes.Stype_Definition'Class) is use type Mappings.Mapping_Definition_Access; Name : constant String := Stype.Get_Name; Result : Gen.Model.Mappings.Mapping_Definition_Access := null; Kind : Mappings.Basic_Type := Mappings.T_INTEGER; begin Log.Info ("Registering simple data type {0}", Name); O.Register_Package (Stype.Pkg_Name, Stype.Package_Def); if Stype.Package_Def.Stypes.Find (Name) /= null then raise Name_Exist with "Data type '" & Name & "' already defined"; end if; Stype.Package_Def.Stypes.Append (Stype.all'Access); Stype.Package_Def.Types.Include (Stype.Name, Stype.all'Access); O.Stypes.Append (Stype.all'Access); if Length (Stype.Parent_Type) > 0 then Result := Gen.Model.Mappings.Find_Type (Stype.Parent_Type, False); if Result /= null then Kind := Result.Kind; end if; end if; Gen.Model.Mappings.Register_Type (Stype.Get_Name, Stype.all'Access, Kind); end Register_Stype; -- ------------------------------ -- Register the declaration of the given table in the model. -- ------------------------------ procedure Register_Table (O : in out Model_Definition; Table : access Gen.Model.Tables.Table_Definition'Class) is Name : constant String := Table.Get_Name; begin Log.Info ("Registering table {0}", Name); O.Register_Package (Table.Pkg_Name, Table.Package_Def); if Table.Package_Def.Tables.Find (Name) /= null then raise Name_Exist with "Table '" & Name & "' already defined"; end if; Table.Package_Def.Tables.Append (Table.all'Access); Table.Package_Def.Types.Include (Table.Name, Table.all'Access); if O.Is_Generation_Enabled (To_String (Table.Pkg_Name)) then O.Tables.Append (Table.all'Access); end if; end Register_Table; -- ------------------------------ -- Register the declaration of the given query in the model. -- ------------------------------ procedure Register_Query (O : in out Model_Definition; Table : access Gen.Model.Queries.Query_File_Definition'Class) is begin O.Register_Package (Table.Pkg_Name, Table.Package_Def); Table.Package_Def.Queries.Append (Table.all'Access); O.Queries.Append (Table.all'Access); end Register_Query; -- ------------------------------ -- Register the declaration of the given bean in the model. -- ------------------------------ procedure Register_Bean (O : in out Model_Definition; Bean : access Gen.Model.Beans.Bean_Definition'Class) is begin O.Register_Package (Bean.Pkg_Name, Bean.Package_Def); Bean.Package_Def.Beans.Append (Bean.all'Access); Bean.Package_Def.Types.Include (Bean.Name, Bean.all'Access); O.Queries.Append (Bean.all'Access); end Register_Bean; -- ------------------------------ -- Register or find the package knowing its name -- ------------------------------ procedure Register_Package (O : in out Model_Definition; Name : in UString; Result : out Package_Definition_Access) is Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name)); Key : constant UString := To_UString (Pkg); Pos : constant Package_Map.Cursor := O.Packages.Find (Key); begin if not Package_Map.Has_Element (Pos) then declare Map : Ada.Strings.Maps.Character_Mapping; Base_Name : UString; begin Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-"); Base_Name := Translate (Name, Map); Result := new Package_Definition; Result.Set_Name (Name); Result.Model := O'Unchecked_Access; Result.Tables_Bean := UBO.To_Object (Result.Tables'Access, UBO.STATIC); Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name), Result.Base_Name); O.Packages.Insert (Key, Result); Log.Debug ("Ada package '{0}' registered", Name); end; else Result := Package_Map.Element (Pos); end if; end Register_Package; -- ------------------------------ -- Returns True if the model contains at least one package. -- ------------------------------ function Has_Packages (O : in Model_Definition) return Boolean is begin return not O.Packages.Is_Empty; end Has_Packages; -- ------------------------------ -- 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 (Model : in out Model_Definition; Name : in String) is begin Model.Gen_Packages.Include (Util.Strings.Transforms.To_Upper_Case (Name)); end Enable_Package_Generation; -- ------------------------------ -- Returns True if the generation is enabled for the given package name. -- ------------------------------ function Is_Generation_Enabled (Model : in Model_Definition; Name : in String) return Boolean is Upper_Name : constant String := Util.Strings.Transforms.To_Upper_Case (Name); Key : constant UString := To_UString (Upper_Name); begin return not Model.Packages.Element (Key).Is_Predefined and then (Model.Gen_Packages.Is_Empty or else Model.Gen_Packages.Contains (Upper_Name)); end Is_Generation_Enabled; -- ------------------------------ -- Iterate over the model tables. -- ------------------------------ procedure Iterate_Tables (Model : in Model_Definition; Process : not null access procedure (Item : in out Tables.Table_Definition)) is procedure Process_Definition (Item : in Definition_Access); procedure Process_Definition (Item : in Definition_Access) is begin Process (Tables.Table_Definition (Item.all)); end Process_Definition; begin Model.Tables.Iterate (Process_Definition'Access); end Iterate_Tables; -- ------------------------------ -- Iterate over the model enums. -- ------------------------------ procedure Iterate_Enums (Model : in Model_Definition; Process : not null access procedure (Item : in out Enums.Enum_Definition)) is procedure Process_Definition (Item : in Definition_Access); procedure Process_Definition (Item : in Definition_Access) is begin Process (Enums.Enum_Definition (Item.all)); end Process_Definition; begin Model.Enums.Iterate (Process_Definition'Access); end Iterate_Enums; -- ------------------------------ -- Prepare the generation of the package: -- o identify the column types which are used -- o build a list of package for the with clauses. -- ------------------------------ overriding procedure Prepare (O : in out Package_Definition) is use Gen.Model.Tables; procedure Prepare_Operations (List : in Operation_List.List_Definition); procedure Prepare_Table (Table : in Table_Definition_Access); procedure Prepare_Definition (Def : in Definition_Access); procedure Collect_Dependencies (Table : in Definition_Access); procedure Set_Used_Packages (Into : in out List_Object; Used_Types : in Gen.Utils.String_Set.Set); Used_Spec_Types : Gen.Utils.String_Set.Set; Used_Body_Types : Gen.Utils.String_Set.Set; -- ------------------------------ -- Look at the operations used to add the necessary with clauses for parameters. -- ------------------------------ procedure Prepare_Operations (List : in Tables.Operation_List.List_Definition) is use type Operations.Operation_Type; Iter : Operation_List.Cursor := List.First; begin while Operation_List.Has_Element (Iter) loop case Operation_List.Element (Iter).Get_Type is when Operations.UNKNOWN => null; when Operations.ASF_ACTION => Used_Spec_Types.Include (To_UString ("Util.Beans.Methods")); Used_Body_Types.Include (To_UString ("ASF.Events.Faces.Actions")); when Operations.ASF_UPLOAD => Used_Spec_Types.Include (To_UString ("Util.Beans.Methods")); Used_Spec_Types.Include (To_UString ("ASF.Parts")); Used_Body_Types.Include (To_UString ("ASF.Parts.Upload_Method")); when Operations.AWA_EVENT => Used_Spec_Types.Include (To_UString ("Util.Beans.Methods")); Used_Spec_Types.Include (To_UString ("AWA.Events")); Used_Body_Types.Include (To_UString ("AWA.Events.Action_Method")); end case; Operation_List.Next (Iter); end loop; end Prepare_Operations; procedure Prepare_Table (Table : in Table_Definition_Access) is C : Column_List.Cursor := Table.Members.First; begin Table.Prepare; -- Walk the columns to get their type. while Column_List.Has_Element (C) loop declare use type Model.Mappings.Basic_Type; use type Model.Mappings.Mapping_Definition_Access; Col : constant Column_Definition_Access := Column_List.Element (C); T : constant Model.Mappings.Mapping_Definition_Access := Col.Get_Type_Mapping; Name : constant String := To_String (Col.Type_Name); Pkg : constant String := Gen.Utils.Get_Package_Name (Name); begin if T = null then Log.Error ("Column {0} has null type in table {1} - type is name {2}", Col.Get_Name, Table.Get_Name, Name); else case T.Kind is when Model.Mappings.T_DATE => O.Uses_Calendar_Time := True; when Model.Mappings.T_ENUM | Model.Mappings.T_BEAN | Model.Mappings.T_TABLE => if Pkg'Length > 0 and then Pkg /= O.Name and then not Col.Use_Foreign_Key_Type then Used_Spec_Types.Include (To_UString (Pkg)); end if; when others => if T.Kind /= Model.Mappings.T_DATE and then Name in "Date" | "DateTime" | "Time" then Log.Error ("Date type {0} is invalid in table {1} - type is name {2}", Model.Mappings.Basic_Type'Image (T.Kind), Table.Get_Name, Name); end if; end case; end if; end; Column_List.Next (C); end loop; Prepare_Operations (Table.Operations); -- If the table is using serialization, add the Serializable.IO package. if Table.Is_Serializable then Used_Spec_Types.Include (To_UString ("Util.Serialize.IO")); Used_Body_Types.Include (To_UString ("ADO.Utils.Serialize")); end if; if Table.Is_Auditable then Used_Spec_Types.Include (To_UString ("ADO.Audits")); end if; end Prepare_Table; procedure Prepare_Definition (Def : in Definition_Access) is begin if Def.all in Table_Definition'Class then Prepare_Table (Table_Definition_Access (Def)); else Def.Prepare; end if; end Prepare_Definition; procedure Collect_Dependencies (Table : in Definition_Access) is begin if Table.all in Table_Definition'Class then Table_Definition'Class (Table.all).Collect_Dependencies; end if; end Collect_Dependencies; procedure Set_Used_Packages (Into : in out List_Object; Used_Types : in Gen.Utils.String_Set.Set) is P : Gen.Utils.String_Set.Cursor := Used_Types.First; begin while Gen.Utils.String_Set.Has_Element (P) loop declare Name : constant UString := Gen.Utils.String_Set.Element (P); begin Log.Info ("with {0}", Name); Into.Values.Append (UBO.To_Object (Name)); end; Gen.Utils.String_Set.Next (P); end loop; end Set_Used_Packages; begin Log.Info ("Preparing package {0}", O.Name); O.Used_Spec_Types.Row := 0; O.Used_Spec_Types.Values.Clear; O.Used_Body_Types.Row := 0; O.Used_Body_Types.Values.Clear; O.Uses_Calendar_Time := False; O.Enums.Sort; O.Queries.Sort; O.Enums.Iterate (Process => Prepare_Definition'Access); O.Tables.Iterate (Process => Prepare_Definition'Access); O.Queries.Iterate (Process => Prepare_Definition'Access); O.Beans.Iterate (Process => Prepare_Definition'Access); -- Collect the table dependencies and sort the tables so that tables that depend on -- others are processed at the end. O.Tables.Iterate (Process => Collect_Dependencies'Access); Dependency_Sort (O.Tables); Set_Used_Packages (O.Used_Spec_Types, Used_Spec_Types); Set_Used_Packages (O.Used_Body_Types, Used_Body_Types); end Prepare; -- ------------------------------ -- Validate the definition by checking and reporting problems to the logger interface. -- ------------------------------ overriding procedure Validate (Def : in out Package_Definition; Log : in out Util.Log.Logging'Class) is procedure Validate_Definition (Def : in Definition_Access); procedure Validate_Definition (Def : in Definition_Access) is begin Def.Validate (Log); end Validate_Definition; begin Def.Tables.Iterate (Process => Validate_Definition'Access); Def.Beans.Iterate (Process => Validate_Definition'Access); end Validate; -- ------------------------------ -- Initialize the package instance -- ------------------------------ overriding procedure Initialize (O : in out Package_Definition) is begin O.Enums_Bean := UBO.To_Object (O.Enums'Unchecked_Access, UBO.STATIC); O.Stypes_Bean := UBO.To_Object (O.Stypes'Unchecked_Access, UBO.STATIC); O.Tables_Bean := UBO.To_Object (O.Tables'Unchecked_Access, UBO.STATIC); O.Queries_Bean := UBO.To_Object (O.Queries'Unchecked_Access, UBO.STATIC); O.Beans_Bean := UBO.To_Object (O.Beans'Unchecked_Access, UBO.STATIC); O.Used_Spec := UBO.To_Object (O.Used_Spec_Types'Unchecked_Access, UBO.STATIC); O.Used_Body := UBO.To_Object (O.Used_Body_Types'Unchecked_Access, UBO.STATIC); end Initialize; -- ------------------------------ -- Get the number of elements in the list. -- ------------------------------ overriding function Get_Count (From : List_Object) return Natural is begin Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length))); return Natural (From.Values.Length); end Get_Count; -- ------------------------------ -- Set the current row index. Valid row indexes start at 1. -- ------------------------------ overriding procedure Set_Row_Index (From : in out List_Object; Index : in Natural) is begin Log.Debug ("Setting row {0}", Natural'Image (Index)); From.Row := Index; end Set_Row_Index; -- ------------------------------ -- Get the element at the current row index. -- ------------------------------ overriding function Get_Row (From : List_Object) return UBO.Object is begin Log.Debug ("Getting row {0}", Natural'Image (From.Row)); return From.Values.Element (From.Row); end Get_Row; -- ------------------------------ -- Get the value identified by the name. -- If the name cannot be found, the method should return the Null object. -- ------------------------------ overriding function Get_Value (From : in List_Object; Name : in String) return UBO.Object is pragma Unreferenced (From); pragma Unreferenced (Name); begin return UBO.Null_Object; end Get_Value; -- ------------------------------ -- Get the value identified by the name. -- If the name cannot be found, the method should return the Null object. -- ------------------------------ overriding function Get_Value (From : in Model_Definition; Name : in String) return UBO.Object is begin if Name = "tables" then return From.Tables_Bean; elsif Name = "dirname" then return UBO.To_Object (From.Dir_Name); else return Definition (From).Get_Value (Name); end if; end Get_Value; -- ------------------------------ -- Set the directory name associated with the model. This directory name allows to -- save and build a model in separate directories for the application, the unit tests -- and others. -- ------------------------------ procedure Set_Dirname (O : in out Model_Definition; Target_Dir : in String; Model_Dir : in String) is begin O.Dir_Name := To_UString (Target_Dir); O.DB_Name := To_UString (Model_Dir); end Set_Dirname; -- ------------------------------ -- Get the directory name associated with the model. -- ------------------------------ function Get_Dirname (O : in Model_Definition) return String is begin return To_String (O.Dir_Name); end Get_Dirname; -- ------------------------------ -- Get the directory name which contains the model. -- ------------------------------ function Get_Model_Directory (O : in Model_Definition) return String is begin return To_String (O.DB_Name); end Get_Model_Directory; -- ------------------------------ -- Initialize the model definition instance. -- ------------------------------ overriding procedure Initialize (O : in out Model_Definition) is T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access; begin O.Tables_Bean := UBO.To_Object (T, UBO.STATIC); O.Dir_Name := To_UString ("src"); end Initialize; -- ------------------------------ -- Prepare the generation of the package: -- o identify the column types which are used -- o build a list of package for the with clauses. -- ------------------------------ overriding procedure Prepare (O : in out Model_Definition) is begin for P of O.Packages loop P.Prepare; end loop; O.Tables.Sort; end Prepare; -- ------------------------------ -- Validate the definition by checking and reporting problems to the logger interface. -- ------------------------------ overriding procedure Validate (Def : in out Model_Definition; Log : in out Util.Log.Logging'Class) is begin for P of Def.Packages loop P.Validate (Log); end loop; end Validate; -- ------------------------------ -- Get the first package of the model definition. -- ------------------------------ function First (From : Model_Definition) return Package_Cursor is begin return From.Packages.First; end First; -- ------------------------------ -- Register a type mapping. The From type describes a type in the XML -- configuration files (hibernate, query, ...) and the To represents the -- corresponding Ada type. -- ------------------------------ procedure Register_Type (O : in out Model_Definition; From : in String; To : in String) is begin null; end Register_Type; -- ------------------------------ -- Returns False if the Left table does not depend on Right. -- Returns True if the Left table depends on the Right table. -- ------------------------------ function Dependency_Compare (Left, Right : in Definition_Access) return Boolean is use Gen.Model.Tables; T_Left : constant Table_Definition_Access := Table_Definition'Class (Left.all)'Access; T_Right : constant Table_Definition_Access := Table_Definition'Class (Right.all)'Access; begin Log.Info ("Table {0} and {1} do not depend on each other", To_String (Left.Name), To_String (Right.Name)); case Gen.Model.Tables.Depends_On (T_Left, T_Right) is when FORWARD => return False; when BACKWARD => return True; when others => -- Two tables that don't depend on each other are sorted on their name. return Left.Name < Right.Name; end case; end Dependency_Compare; -- ------------------------------ -- Find the type identified by the name. -- ------------------------------ function Find_Type (From : in Model_Definition; Name : in UString) return Gen.Model.Mappings.Mapping_Definition_Access is N : constant Natural := Ada.Strings.Unbounded.Index (Name, ".", Ada.Strings.Backward); L : constant Natural := Ada.Strings.Unbounded.Length (Name); begin if N = 0 then return null; end if; declare Pkg_Name : constant String := Ada.Strings.Unbounded.Slice (Name, 1, N - 1); Base_Name : constant String := Ada.Strings.Unbounded.Slice (Name, N + 1, L); Key : constant String := Util.Strings.Transforms.To_Upper_Case (Pkg_Name); Pos : constant Package_Map.Cursor := From.Packages.Find (To_UString (Key)); begin if Package_Map.Has_Element (Pos) then return Package_Map.Element (Pos).Find_Type (To_UString (Base_Name)); else return null; end if; end; end Find_Type; end Gen.Model.Packages;