------------------------------------------------------------------------------ -- Templates Parser -- -- -- -- Copyright (C) 1999-2019, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3, or (at your option) any -- -- later version. This library is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Finalization; with Ada.Strings.Unbounded; with Templates_Parser_Tasking; pragma Elaborate_All (Templates_Parser_Tasking); pragma Warnings (Off, Templates_Parser_Tasking); -- This unit is not used in the spec but is placed here to force proper -- finalization order. private with Ada.Containers.Indefinite_Hashed_Maps; private with Ada.Containers.Indefinite_Hashed_Sets; private with Ada.Strings.Hash; package Templates_Parser is use Ada.Strings.Unbounded; function Version return String with Inline; Template_Error : exception; Default_Begin_Tag : constant String := "@_"; Default_End_Tag : constant String := "_@"; Default_Separator : constant String := ", "; procedure Set_Tag_Separators (Start_With : String := Default_Begin_Tag; Stop_With : String := Default_End_Tag) with Pre => Start_With'Length > 0 and then Stop_With'Length > 0; -- Set the tag separators for the whole session. This should be changed as -- the very first API call and should not be changed after. function Tag_From_Name (Name : String) return String with Post => Tag_From_Name'Result'Length >= Name'Length + 2; -- Returns the tag given the Name, default is @_NAME_@ ----------------- -- Generic Tag -- ----------------- type Tag is private; -- A tag is using a by reference semantic function "+" (Value : String) return Tag with Post => Size ("+"'Result) = 1; function "+" (Value : Character) return Tag with Post => Size ("+"'Result) = 1; function "+" (Value : Boolean) return Tag with Post => Size ("+"'Result) = 1; function "+" (Value : Unbounded_String) return Tag with Post => Size ("+"'Result) = 1; function "+" (Value : Integer) return Tag with Post => Size ("+"'Result) = 1; function "+" (Value : Tag) return Tag with Post => Size ("+"'Result) = 1; -- Tag constructors function "&" (T : Tag; Value : String) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (T : Tag; Value : Character) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (T : Tag; Value : Boolean) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (T : Tag; Value : Unbounded_String) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (T : Tag; Value : Integer) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (T : Tag; Value : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; -- Add Value at the end of the tag, note that "&" will modify its -- first parameter. It is intended to be used as [T := T & "val"], -- doing [T1 := T2 & "val"] will add val to T2 and set T1 as an -- alias. This is designed this way for efficiency. function "&" (Value : String; T : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (Value : Character; T : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (Value : Boolean; T : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (Value : Unbounded_String; T : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; function "&" (Value : Integer; T : Tag) return Tag with Post => Size ("&"'Result) = Size (T)'Old + 1; -- Add Value at the front of the tag, see note above procedure Append (T : in out Tag; Value : String) with Post => Size (T) = Size (T)'Old + 1; procedure Append (T : in out Tag; Value : Character) with Post => Size (T) = Size (T)'Old + 1; procedure Append (T : in out Tag; Value : Boolean) with Post => Size (T) = Size (T)'Old + 1; procedure Append (T : in out Tag; Value : Unbounded_String) with Post => Size (T) = Size (T)'Old + 1; procedure Append (T : in out Tag; Value : Integer) with Post => Size (T) = Size (T)'Old + 1; procedure Append (T : in out Tag; Value : Tag) with Post => Size (T) = Size (T)'Old + 1; -- Add Value at the end of tag procedure Set_Separator (T : in out Tag; Separator : String); -- Set separator to be used when building a flat representation of -- a composite tag. procedure Clear (T : in out Tag) with Post => Size (T) = 0; -- Removes all values in the tag. Current tag T is not released but -- the returned object is separated (not using the same reference) than -- the original one. function Size (T : Tag) return Natural; -- Returns the number of value into T function Item (T : Tag; N : Positive) return String with Pre => N <= Size (T); -- Returns the Nth Tag's item. Raises Constraint_Error if there is -- no such Item in T (i.e. T length < N). function Composite (T : Tag; N : Positive) return Tag with Pre => N <= Size (T); -- Returns the Nth Tag's item. Raises Constraint_Error if there is -- no such Item in T (i.e. T length < N). subtype Vector_Tag is Tag; subtype Matrix_Tag is Tag; ------------------ -- Associations -- ------------------ type Association is private; Null_Association : constant Association; type Association_Kind is (Std, Composite); -- The kind of association which is either Std (a simple value), a vector -- tag or a Matrix tag. function Assoc (Variable : String; Value : String) return Association with Pre => Variable'Length > 0; -- Build an Association (Variable = Value) to be added to a -- Translate_Set. This is a standard association, value is a string. function Assoc (Variable : String; Value : Unbounded_String) return Association with Pre => Variable'Length > 0; -- Build an Association (Variable = Value) to be added to a -- Translate_Set. This is a standard association, value is an -- Unbounded_String. function Assoc (Variable : String; Value : Integer) return Association with Pre => Variable'Length > 0; -- Build an Association (Variable = Value) to be added to a -- Translate_Set. This is a standard association, value is an Integer. -- It will be displayed without leading space if positive. function Assoc (Variable : String; Value : Boolean) return Association with Pre => Variable'Length > 0; -- Build an Association (Variable = Value) to be added to a -- Translate_Set. It set the variable to TRUE or FALSE depending on -- value. function Assoc (Variable : String; Value : Tag; Separator : String := Default_Separator) return Association with Pre => Variable'Length > 0; -- Build an Association (Variable = Value) to be added to Translate_Set. -- This is a tag association. Separator will be used when outputting the -- a flat representation of the Tag (outside a table statement). function Get (Assoc : Association) return Tag; -- Returns the Tag in Assoc, raise Constraint_Error if Assoc is not -- containing a Tag (Association_Kind is Std). -- See also the Templates_Parser.Query package for other functions to -- manipulate associations. function Get (Assoc : Association) return String; -- Returns the value in Assoc, raise Constraint_Error if Assoc is not -- containing a simple value (Association_Kind is Composite). -- See also the Templates_Parser.Query package for other functions to -- manipulate associations. --------------------------- -- Association table/set -- --------------------------- type Translate_Table is array (Positive range <>) of Association; -- A table with a set of associations, note that it is better to use -- Translate_Set below as it is more efficient. No_Translation : constant Translate_Table; type Translate_Set is private; -- This is a set of association like Translate_Table but it is possible to -- insert item into this set more easily, furthermore there is no need to -- know the number of item before hand. This is the object used internally -- by the templates engine as it is far more efficient to retrieve a -- specific item from it. Null_Set : constant Translate_Set; procedure Insert (Set : in out Translate_Set; Item : Association) with Post => Size (Set) >= Size (Set)'Old; -- Add Item into the translate set. If an association for this variable -- already exists it just replaces it by the new item. procedure Insert (Set : in out Translate_Set; Items : Translate_Set) with Post => Size (Set) >= Size (Set)'Old; -- Add Items into the translate set. If an association for variables in -- Items already exists it just replaces it by the new one. function "&" (Left : Association; Right : Association) return Translate_Set with Inline; -- Returns new translate set created from 2 associations. If names of -- both associations are the same, the returned translate set will -- contain only Right. function "&" (Set : Translate_Set; Item : Association) return Translate_Set with Inline; -- Adds Item into Set. If an association with the same name already exists -- in Set it is replaced by the new one. Note that "&" will modify its -- first parameter. It is intended to be used as [T := T & Assoc], -- doing [T1 := T2 & Assoc] will add Assoc into T2 and set T1 as an -- alias. This is designed this way for efficiency. function "+" (Item : Association) return Translate_Set with Inline => True, Post => Size ("+"'Result) = 1; -- Create translate set from one association procedure Remove (Set : in out Translate_Set; Name : String) with Pre => Name'Length > 0, Post => not Exists (Set, Name); -- Removes association named Name from the Set. Does nothing if there is -- not such association in the set. function Get (Set : Translate_Set; Name : String) return Association with Pre => Name'Length > 0, Post => (if not Exists (Set, Name) then Get'Result = Null_Association); -- Returns the association named Name in the Set. Returns Null_Association -- is no such association if found in Set. function Size (Set : Translate_Set) return Natural; -- Returns size of the translate set function Exists (Set : Translate_Set; Variable : String) return Boolean with Pre => Variable'Length > 0; -- Returns True if an association for Variable exists into the Set generic with procedure Action (Item : Association; Quit : in out Boolean); procedure For_Every_Association (Set : Translate_Set); -- Iterates through all associations in the set, call Action for each one. -- Set Quit to True to stop the iteration. function To_Set (Table : Translate_Table) return Translate_Set with Post => Size (To_Set'Result) = Table'Length; -- Convert a Translate_Table into a Translate_Set ------------- -- Dynamic -- ------------- package Dynamic is -------------- -- Lazy_Tag -- -------------- type Lazy_Tag is abstract tagged private; type Lazy_Tag_Access is access all Lazy_Tag'Class; procedure Value (Lazy_Tag : not null access Dynamic.Lazy_Tag; Var_Name : String; Translations : in out Translate_Set) is abstract; -- Value is called by the Parse routines below if a tag variable was not -- found in the set of translations. This routine must then add the -- association for variable Name. It is possible to add other -- associations in the translation table but a check is done to see if -- the variable Name as been set or not. The default implementation does -- nothing. Null_Lazy_Tag : constant Lazy_Tag_Access; ---------------- -- Cursor_Tag -- ---------------- type Cursor_Tag is abstract tagged private; type Cursor_Tag_Access is access all Cursor_Tag'Class; -- In some cases it is difficult and not efficient to have to map all -- Ada data into a template Tag. A Cursor_Tag object gives the ability -- to iterate through a data structure which is living on the Ada side -- only. function Dimension (Cursor_Tag : not null access Dynamic.Cursor_Tag; Var_Name : String) return Natural is abstract; -- Must return the number of dimensions for the given variable name. For -- a matrix this routine should return 2 for example. type Path is array (Positive range <>) of Natural; -- A Path gives the full position of a given element in the cursor tag function Length (Cursor_Tag : not null access Dynamic.Cursor_Tag; Var_Name : String; Path : Dynamic.Path) return Natural is abstract; -- Must return the number of item for the given path. The first -- dimension is given by the Path (1), for the second column the Path is -- (1, 2). Note that each dimension can have a different length. For -- example a Matrix is not necessary square. function Value (Cursor_Tag : not null access Dynamic.Cursor_Tag; Var_Name : String; Path : Dynamic.Path) return String is abstract; -- Must return the value for the variable at the given Path. Note that -- this routine will be called only for valid items as given by the -- Dimension and Length above. Null_Cursor_Tag : constant Cursor_Tag_Access; private type Lazy_Tag is abstract tagged null record; Null_Lazy_Tag : constant Lazy_Tag_Access := null; type Cursor_Tag is abstract tagged null record; Null_Cursor_Tag : constant Cursor_Tag_Access := null; end Dynamic; package Dyn renames Dynamic; -------------------- -- User's Filters -- -------------------- type Filter_Context is record Translations : Translate_Set; Lazy_Tag : Dynamic.Lazy_Tag_Access; end record; type Callback is access function (Value : String; Parameters : String; Context : Filter_Context) return String; -- User's filter callback type Callback_No_Param is access function (Value : String; Context : Filter_Context) return String; -- User's filter callback procedure Register_Filter (Name : String; Handler : Callback); -- Register user's filter Name using the specified Handler procedure Register_Filter (Name : String; Handler : Callback_No_Param); -- Register user's filter Name using the specified Handler type User_Filter is abstract tagged private; type User_Filter_Access is access all User_Filter'Class; function Execute (Filter : not null access User_Filter; Value : String; Parameters : String; Context : Filter_Context) return String is abstract; -- User filters can also be implemented through a tagged type, which allows -- you to add your own user data and reuse a filter in several -- applications, perhaps with a slightly different behavior each time. -- It is possible for the callback to modify the data stored in Filter, but -- this needs to be done with care, since multiple concurrent calls to -- Callback might happen. procedure Register_Filter (Name : String; Filter : not null access User_Filter'Class); -- Register a new filter. Filter must not be freed by the caller, since no -- copy is made. procedure Free_Filters; -- Free all user filters registered above. This is mostly intended when -- you are testing memory leaks in your application. ----------- -- Macro -- ----------- type Parameter_Set is array (Natural range <>) of Unbounded_String; No_Parameter : constant Parameter_Set; type Macro_Callback is access function (Name : String; Parameters : Parameter_Set) return String; procedure Register_Macro_Handler (Callback : Macro_Callback); -- Use the given callbacks for every unknown macro in the template. The -- default implementation of this routine just displays the macro (name -- and parameters). ----------------------------- -- Parsing and Translating -- ----------------------------- type Reason_Kind is (Unused, Undefined); function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return String with Pre => Filename'Length > 0; -- Parse the Template_File replacing variables' occurrences by the -- corresponding values. If Cached is set to True, Filename tree will be -- recorded into a cache for quick retrieval. If Keep_Unknown_Tags is set -- to True then tags that are not in the translate table are kept -- as-is if it is part of the template data. If this tags is part of a -- condition (in an IF statement tag), the condition will evaluate to -- False. function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return Unbounded_String with Pre => Filename'Length > 0; -- Idem but returns an Unbounded_String function Parse (Filename : String; Translations : Translate_Set; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return String with Pre => Filename'Length > 0; -- Idem with a Translation_Set function Parse (Filename : String; Translations : Translate_Set; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return Unbounded_String with Pre => Filename'Length > 0; -- Idem with a Translation_Set function Translate (Template : String; Translations : Translate_Table := No_Translation) return String; -- Just translate the discrete variables in the Template string using the -- Translations table. This function does not parse the command tag (TABLE, -- IF, INCLUDE). All composite tags are replaced by the empty string. function Translate (Template : String; Translations : Translate_Set) return String; -- Idem with a Translation_Set procedure Release_Cache; -- Release the internal cache. This free the memory used for all currently -- loaded template trees. private use Ada; type Integer_Access is access Integer; ------------------ -- Generic Tags -- ------------------ type Node_Kind is (Value, Value_Set); type Tag_Access is access Tag; type Tag_Node (Kind : Node_Kind); type Tag_Node_Access is access Tag_Node; type Tag_Node (Kind : Node_Kind) is record Next : Tag_Node_Access; case Kind is when Value => V : Unbounded_String; when Value_Set => VS : Tag_Access; end case; end record; type Tag_Node_Arr is array (Positive range <>) of Tag_Node_Access; type Tag_Node_Arr_Access is access Tag_Node_Arr; package Tag_Values is new Containers.Indefinite_Hashed_Sets (String, Strings.Hash, "="); type Tag_Values_Access is access Tag_Values.Set; -- Map for all tag values to speed-up "in" operator type Tag_Data is record Count : Natural; -- Number of items Min, Max : Natural; -- Min/Max item's sizes, equal to 1 if leaf Nested_Level : Positive; -- Number of composite structures Separator : Unbounded_String; Head : Tag_Node_Access; Last : Tag_Node_Access; Tag_Nodes : Tag_Node_Arr_Access; -- This array will be setup during parsing to ensure fast iteration -- in reverse order. Values : Tag_Values_Access; end record; type Tag_Data_Access is access Tag_Data; type Tag is new Ada.Finalization.Controlled with record Ref_Count : Integer_Access; Data : Tag_Data_Access; end record; overriding procedure Initialize (T : in out Tag); overriding procedure Finalize (T : in out Tag); overriding procedure Adjust (T : in out Tag); subtype Indices is Dynamic.Path; -- Set of indices that reference a specific item into a composite tag. -- Used by the parser. procedure Field (T : Tag; N : Positive; Result : out Tag; Found : out Boolean); -- Returns the N'th item in Tag. Found is set to False is there is no -- such item. ------------------ -- Association -- ------------------ type Association (Kind : Association_Kind := Std) is record Variable : Unbounded_String; case Kind is when Std => Value : Unbounded_String; when Composite => Comp_Value : Tag; end case; end record; Null_Association : constant Association := (Std, Null_Unbounded_String, Null_Unbounded_String); No_Translation : constant Translate_Table := (2 .. 1 => Null_Association); ----------- -- Debug -- ----------- Expand_Macro : Boolean := False; -- If set to true the macro will be displayed inline instead of the named -- reference. procedure Print_Tree (Filename : String); -- Use for debugging purpose only, it will output the internal tree -- representation. procedure Print_Defined_Macros; -- Use for debugging purpose only, output all defined macros -------------------- -- Translate_Set -- -------------------- package Association_Map is new Containers.Indefinite_Hashed_Maps (String, Association, Strings.Hash, "=", "="); type Map_Access is access Association_Map.Map; type Translate_Set is new Ada.Finalization.Controlled with record Ref_Count : Integer_Access; Set : Map_Access; end record; overriding procedure Initialize (Set : in out Translate_Set); overriding procedure Finalize (Set : in out Translate_Set); overriding procedure Adjust (Set : in out Translate_Set); Null_Set : constant Translate_Set := (Ada.Finalization.Controlled with null, null); ------------------ -- User filters -- ------------------ type User_Filter is abstract tagged null record; No_Parameter : constant Parameter_Set := (1 .. 0 => <>); end Templates_Parser;