------------------------------------------------------------------------------
-- Templates Parser --
-- --
-- Copyright (C) 1999-2015, 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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;
Version : constant String := "11.10.1";
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 --
-----------------------------
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)
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)
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)
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)
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
-- implementation removed
end Templates_Parser;
