------------------------------------------------------------------------------
-- 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.Text_IO;
separate (Templates_Parser)
package body Data is
-----------
-- Build --
-----------
function Build (Str : String) return Tag_Var is
function Get_Var_Name (Tag : String) return String;
-- Given a Tag name, it returns the variable name only. It removes
-- the tag separator and the filters.
function Get_Filter_Set (Tag : String) return Filter.Set_Access;
-- Given a tag name, it retruns a set of filter to apply to this
-- variable when translated.
function Get_Attribute (Tag : String) return Attribute_Data;
-- Returns attribute for the given tag
function Is_Internal (Name : String) return Internal_Tag;
-- Returns True if Name is an internal tag
function Is_Macro return Boolean with Inline;
-- Returns True if we are parsing a macro
F_Sep : constant Natural :=
Strings.Fixed.Index (Str, ":", Strings.Backward);
-- Last filter separator
A_Sep : Natural :=
Strings.Fixed.Index (Str, "'", Strings.Backward);
-- Attribute separator
MP_Start, MP_End : Natural := 0;
-- Start/End of the macro parameters, 0 if not a macro
-------------------
-- Get_Attribute --
-------------------
function Get_Attribute (Tag : String) return Attribute_Data is
Start, Stop : Natural;
begin
if A_Sep = 0 then
return No_Attribute;
else
Start := A_Sep + 1;
Stop := Tag'Last - Length (End_Tag);
end if;
declare
A_Name : constant String :=
Characters.Handling.To_Lower (Tag (Start .. Stop));
begin
if A_Name = "length" then
return (Length, 0);
elsif A_Name = "line" then
return (Line, 0);
elsif A_Name = "min_column" then
return (Min_Column, 0);
elsif A_Name = "max_column" then
return (Max_Column, 0);
elsif A_Name'Length >= 8
and then A_Name (A_Name'First .. A_Name'First + 7) = "up_level"
then
if A_Name'Length > 8 then
-- We have a parameter
declare
V : constant String :=
Strings.Fixed.Trim
(A_Name (A_Name'First + 8 .. A_Name'Last),
Strings.Both);
N : Integer;
begin
if V (V'First) = '('
and then V (V'Last) = ')'
and then Is_Number (V (V'First + 1 .. V'Last - 1))
then
N := Integer'Value (V (V'First + 1 .. V'Last - 1));
else
raise Template_Error
with "Wrong value for attribute Up_Level";
end if;
return (Up_Level, N);
end;
else
return (Up_Level, 1);
end if;
elsif A_Name = "indent" then
return (Indent, 0);
else
raise Template_Error
with "Unknown attribute name """ & A_Name & '"';
end if;
end;
end Get_Attribute;
--------------------
-- Get_Filter_Set --
--------------------
function Get_Filter_Set (Tag : String) return Filter.Set_Access is
use type Filter.Callback;
Start : Natural;
Stop : Natural := Tag'Last;
FS : Filter.Set (1 .. Strings.Fixed.Count (Tag, ":"));
-- Note that FS can be larger than needed as ':' can be used inside
-- filter parameters for example.
K : Positive := FS'First;
function Name_Parameter
(Filter : String) return Templates_Parser.Filter.Routine;
-- Given a Filter description, returns the filter handle and
-- parameter.
procedure Get_Slice (Slice : String; First, Last : out Integer);
-- Returns the First and Last slice index as parsed into the Slice
-- string. Returns First and Last set to 0 if there is not valid
-- slice definition in Slice.
function Find_Slash (Str : String) return Natural;
-- Returns the first slash index in Str, skip espaced slashes
function Find
(Str : String;
Start : Positive;
C : Character) return Natural;
-- Look backward for character C in Str starting at position Start.
-- This procedure skips quoted strings and parenthesis. Returns 0 if
-- the character if not found otherwize it returns the positon of C
-- in Str.
----------
-- Find --
----------
function Find
(Str : String;
Start : Positive;
C : Character) return Natural
is
Pos : Natural := Start;
Count : Integer := 0;
begin
while Pos > Str'First
and then (Str (Pos) /= C or else Count /= 0)
loop
if Pos > Str'First and then Str (Pos - 1) /= '\' then
-- This is not a quoted character
if Str (Pos) = ')' then
Count := Count - 1;
elsif Str (Pos) = '(' then
Count := Count + 1;
end if;
end if;
Pos := Pos - 1;
end loop;
if Pos = Str'First then
return 0;
else
return Pos;
end if;
end Find;
----------------
-- Find_Slash --
----------------
function Find_Slash (Str : String) return Natural is
Escaped : Boolean := False;
begin
for K in Str'Range loop
if Str (K) = '\' then
Escaped := not Escaped;
elsif Str (K) = '/' and then not Escaped then
return K;
else
Escaped := False;
end if;
end loop;
return 0;
end Find_Slash;
---------------
-- Get_Slice --
---------------
procedure Get_Slice (Slice : String; First, Last : out Integer) is
P1 : constant Natural := Fixed.Index (Slice, "..");
begin
First := 0;
Last := 0;
if P1 = 0 then
raise Template_Error with "slice expected """ & Slice & '"';
else
First := Integer'Value (Slice (Slice'First .. P1 - 1));
Last := Integer'Value (Slice (P1 + 2 .. Slice'Last));
end if;
end Get_Slice;
--------------------
-- Name_Parameter --
--------------------
function Name_Parameter
(Filter : String) return Templates_Parser.Filter.Routine
is
package F renames Templates_Parser.Filter;
use type F.Mode;
function Unescape (Str : String) return String;
-- Unespace characters Str, to be used with regpat replacement
-- pattern.
--------------
-- Unescape --
--------------
function Unescape (Str : String) return String is
S : String (Str'Range);
I : Natural := S'First - 1;
K : Positive := Str'First;
begin
loop
exit when K > Str'Last;
I := I + 1;
if Str (K) = '\'
and then K < Str'Last
and then not (Str (K + 1) in '0' .. '9')
then
-- An escaped character, skip the backslash
K := K + 1;
-- Handle some special escaped characters \n \r \t
case Str (K) is
when 'n' => S (I) := ASCII.LF;
when 'r' => S (I) := ASCII.CR;
when 't' => S (I) := ASCII.HT;
when others => S (I) := Str (K);
end case;
else
S (I) := Str (K);
end if;
K := K + 1;
end loop;
return S (S'First .. I);
end Unescape;
P1 : constant Natural := Fixed.Index (Filter, "(");
P2 : constant Natural := Fixed.Index (Filter, ")", Backward);
begin
if (P1 = 0 and then P2 /= 0) or else (P1 /= 0 and then P2 = 0) then
raise Template_Error
with "unbalanced parenthesis """ & Filter & '"';
elsif P2 /= 0
and then P2 < Filter'Last
and then Filter (P2 + 1) /= ':'
then
raise Template_Error with
"unexpected character after parenthesis """ & Filter & '"';
end if;
if P1 = 0 then
-- No parenthesis, so there is no parameter to parse
if F.Mode_Value (Filter) = F.User_Defined then
return
(F.Handle (Filter),
F.Parameter_Data'(Mode => F.User_Callback,
Handler => F.User_Handle (Filter),
P => Null_Unbounded_String));
else
return (F.Handle (Filter),
Templates_Parser.Filter.No_Parameter);
end if;
else
declare
use GNAT.Regpat;
Name : constant String := Filter (Filter'First .. P1 - 1);
Mode : constant F.Mode := F.Mode_Value (Name);
Parameter : constant String :=
No_Quote (Filter (P1 + 1 .. P2 - 1));
begin
case F.Parameter (Mode) is
when F.Regexp =>
return (F.Handle (Mode),
F.Parameter_Data'
(F.Regexp,
R_Str => To_Unbounded_String (Parameter),
Regexp => new Pattern_Matcher'
(Compile (Parameter))));
when F.Regpat =>
declare
K : constant Natural := Find_Slash (Parameter);
begin
if K = 0 then
-- No replacement, this is equivalent to
-- REPLACE(/\1)
return (F.Handle (Mode),
F.Parameter_Data'
(F.Regpat,
P_Str => To_Unbounded_String
(Parameter),
Regpat => new Pattern_Matcher'
(Compile (Parameter)),
Param => To_Unbounded_String ("\1")));
else
return (F.Handle (Mode),
F.Parameter_Data'
(F.Regpat,
P_Str => To_Unbounded_String
(Parameter
(Parameter'First
.. K - 1)),
Regpat => new Pattern_Matcher'
(Compile
(Parameter
(Parameter'First
.. K - 1))),
Param =>
To_Unbounded_String
(Unescape
(Parameter
(K + 1
.. Parameter'Last)))));
end if;
end;
when F.Slice =>
declare
First, Last : Integer;
begin
Get_Slice (Parameter, First, Last);
return (F.Handle (Mode),
F.Parameter_Data'(F.Slice, First, Last));
end;
when F.Str =>
return (F.Handle (Mode),
F.Parameter_Data'
(F.Str,
S => To_Unbounded_String (Parameter)));
when F.User_Callback =>
return (F.Handle (Mode),
F.Parameter_Data'
(F.User_Callback,
F.User_Handle (Name),
P => To_Unbounded_String (Parameter)));
end case;
end;
end if;
end Name_Parameter;
begin
if FS'Length = 0 then
return null;
end if;
loop
Start := Tag'First;
Stop := Find (Str, Stop, ':');
exit when Stop = 0;
Start := Find (Str, Stop - 1, ':');
if Start = 0 then
-- Last filter found
FS (K) := Name_Parameter
(Tag (Tag'First + Length (Begin_Tag) .. Stop - 1));
else
FS (K) := Name_Parameter (Tag (Start + 1 .. Stop - 1));
end if;
-- Specific check for the NO_DYNAMIC filter which must appear
-- first.
if FS (K).Handle = Filter.No_Dynamic'Access
and then K /= FS'First
then
raise Template_Error with "NO_DYNAMIC must be the first filter";
end if;
K := K + 1;
Stop := Stop - 1;
end loop;
return new Filter.Set'(FS (FS'First .. K - 1));
end Get_Filter_Set;
------------------
-- Get_Var_Name --
------------------
function Get_Var_Name (Tag : String) return String is
Start, Stop : Natural;
begin
if A_Sep = 0 then
-- No attribute
Stop := Tag'Last - Length (End_Tag);
-- Check for macro parameters
if Tag (Stop) = ')' then
MP_End := Stop;
-- Go back to matching open parenthesis
loop
Stop := Stop - 1;
-- ??? check for string literal
exit when Tag (Stop + 1) = '(' or else Stop = Tag'First;
end loop;
MP_Start := Stop + 1;
end if;
else
Stop := A_Sep - 1;
end if;
if F_Sep = 0 then
-- No filter
Start := Tag'First + Length (Begin_Tag);
else
Start := F_Sep + 1;
end if;
return Tag (Start .. Stop);
end Get_Var_Name;
-----------------
-- Is_Internal --
-----------------
function Is_Internal (Name : String) return Internal_Tag is
begin
case Name (Name'First) is
when 'D' =>
if Name = "DAY" then
return Day;
elsif Name = "DAY_NAME" then
return Day_Name;
else
return No;
end if;
when 'H' =>
if Name = "HOUR" then
return Hour;
else
return No;
end if;
when 'M' =>
if Name = "MONTH" then
return Month;
elsif Name = "MONTH_NAME" then
return Month_Name;
elsif Name = "MINUTE" then
return Minute;
else
return No;
end if;
when 'N' =>
if Name = "NOW" then
return Now;
elsif Name = "NUMBER_LINE" then
return Number_Line;
else
return No;
end if;
when 'S' =>
if Name = "SECOND" then
return Second;
else
return No;
end if;
when 'T' =>
if Name = "TABLE_LINE" then
return Table_Line;
elsif Name = "TABLE_LEVEL" then
return Table_Level;
else
return No;
end if;
when 'U' =>
if Name = "UP_TABLE_LINE" then
return Up_Table_Line;
else
return No;
end if;
when 'Y' =>
if Name = "YEAR" then
return Year;
else
return No;
end if;
when others =>
return No;
end case;
end Is_Internal;
--------------
-- Is_Macro --
--------------
function Is_Macro return Boolean is
begin
return MP_Start /= 0 and then MP_End /= 0;
end Is_Macro;
Result : Tag_Var;
begin
if A_Sep <= F_Sep then
-- This is not an attribute in fact, but something like:
-- Filter(that's it):VAR
A_Sep := 0;
end if;
Result.Filters := Get_Filter_Set (Str);
Result.Attribute := Get_Attribute (Str);
declare
Name : constant String := Get_Var_Name (Str);
begin
Result.Name := To_Unbounded_String (Name);
Result.Internal := Is_Internal (Name);
-- If there is no attribute, check for a macro
if Result.Attribute = No_Attribute and then Is_Macro then
Result.Is_Macro := True;
declare
P : constant Templates_Parser.Parameter_Set :=
Get_Parameters (Str (MP_Start .. MP_End));
begin
Result.Parameters := To_Data_Parameters (P);
end;
-- Check if this is a known macro
Result.Def := Clone (Macro.Get (Name));
if Result.Def /= null then
Macro.Rewrite (Result.Def, Result.Parameters);
end if;
end if;
if Name (Name'First) = '$'
and then Strings.Fixed.Count
(Name, Strings.Maps.Constants.Decimal_Digit_Set) = Name'Length - 1
then
Result.N := Natural'Value (Name (Name'First + 1 .. Name'Last));
else
Result.N := -1;
end if;
end;
return Result;
end Build;
-----------
-- Clone --
-----------
function Clone (V : Tag_Var) return Tag_Var is
use type Filter.Set_Access;
R : Tag_Var := V;
begin
if R.Filters /= null then
R.Filters := new Filter.Set'(R.Filters.all);
end if;
if R.Is_Macro then
R.Parameters := new Data.Parameter_Set'(R.Parameters.all);
for K in R.Parameters'Range loop
if R.Parameters (K) /= null then
R.Parameters (K) := Data.Clone (R.Parameters (K));
end if;
end loop;
R.Def := Clone (R.Def);
end if;
return R;
end Clone;
function Clone (D : Tree) return Tree is
Root, N : Tree;
begin
if D /= null then
Root := new Node'(D.all);
N := Root;
loop
if N.Kind = Data.Var then
N.Var := Data.Clone (N.Var);
end if;
exit when N.Next = null;
N.Next := new Node'(N.Next.all);
N := N.Next;
end loop;
end if;
return Root;
end Clone;
-----------
-- Image --
-----------
function Image (T : Tag_Var) return String is
use type Filter.Set_Access;
R : Unbounded_String;
Named : Boolean := False;
begin
R := Begin_Tag;
-- Filters
if T.Filters /= null then
for K in reverse T.Filters'Range loop
Append (R, Filter.Name (T.Filters (K).Handle));
Append (R, Filter.Image (T.Filters (K).Parameters));
Append (R, ":");
end loop;
end if;
-- Tag name
Append (R, T.Name);
-- Macro parameters if any
if T.Is_Macro then
Append (R, "(");
for K in T.Parameters'Range loop
if T.Parameters (K) = null then
Named := True;
else
if Named then
Append (R, Natural'Image (K) & " => ");
end if;
case T.Parameters (K).Kind is
when Text => Append (R, T.Parameters (K).Value);
when Var => Append (R, Image (T.Parameters (K).Var));
end case;
if K /= T.Parameters'Last then
Append (R, ",");
end if;
end if;
end loop;
Append (R, ")");
end if;
-- Attributes
case T.Attribute.Attr is
when Nil => null;
when Length => Append (R, "'Length");
when Line => Append (R, "'Line");
when Min_Column => Append (R, "'Min_Column");
when Max_Column => Append (R, "'Max_Column");
when Indent => Append (R, "'Indent");
when Up_Level =>
Append (R, "'Up_Level");
if T.Attribute.Value /= 1 then
Append (R, '(' & Utils.Image (T.Attribute.Value) & ')');
end if;
end case;
Append (R, End_Tag);
return To_String (R);
end Image;
-------------------------
-- Is_Include_Variable --
-------------------------
function Is_Include_Variable (T : Tag_Var) return Boolean is
begin
return T.N /= -1;
end Is_Include_Variable;
-----------
-- Parse --
-----------
function Parse (Content : String; Line : Natural) return Tree is
Begin_Tag : constant String := To_String (Templates_Parser.Begin_Tag);
End_Tag : constant String := To_String (Templates_Parser.End_Tag);
function Build (Content : String) return Tree;
-- Recursive function to build the tree
-----------
-- Build --
-----------
function Build (Content : String) return Tree is
Start, Stop, S : Natural;
begin
if Content = "" then
return null;
else
Start := Strings.Fixed.Index (Content, Begin_Tag);
if Start = 0 then
-- No more tag
return new Node'(Text,
Line => Line,
Col => Content'First,
Next => null,
Value => To_Unbounded_String (Content));
else
-- Get matching ending separator, a macro can have variables
-- as parameter:
-- @_MACRO(2,@_VAR_@)_@
S := Start + Begin_Tag'Length;
Search_Matching_Tag : loop
Stop := Strings.Fixed.Index (Content, End_Tag, From => S);
S := Strings.Fixed.Index (Content, Begin_Tag, From => S);
exit Search_Matching_Tag when S = 0 or else S > Stop;
S := Stop + End_Tag'Length;
end loop Search_Matching_Tag;
if Stop = 0 then
raise Internal_Error with
"Tag variable not terminated (missing " & End_Tag & ")";
else
Stop := Stop + End_Tag'Length - 1;
if Start = Content'First then
-- The first token in Line is a variable
return new Node'
(Var,
Line => Line,
Col => Start,
Next => Build (Content (Stop + 1 .. Content'Last)),
Var => Build (Content (Start .. Stop)));
else
-- We have some text before the tag
return new Node'
(Text,
Line => Line,
Col => Content'First,
Next => Build (Content (Start .. Content'Last)),
Value => To_Unbounded_String
(Content (Content'First .. Start - 1)));
end if;
end if;
end if;
end if;
end Build;
begin
return Build (Content);
end Parse;
----------------
-- Print_Tree --
----------------
procedure Print_Tree (D : Tree) is
N : Tree := D;
NL : Boolean := False;
begin
while N /= null loop
case N.Kind is
when Text =>
declare
Value : constant String := To_String (N.Value);
VL : constant Natural := Value'Length;
BL : constant Natural := Utils.BOM_Utf8'Length;
begin
if VL >= BL
and then
Value
(Value'First .. Value'First + BL - 1) = Utils.BOM_Utf8
then
Text_IO.Put ("U+");
else
Text_IO.Put (Value);
end if;
if Value'Length > 0 then
NL := Value (Value'Last) = ASCII.LF;
else
NL := False;
end if;
end;
when Var =>
if N.Var.Is_Macro and then Expand_Macro then
Print_Tree (N.Var.Def);
else
Text_IO.Put (Image (N.Var));
NL := False;
end if;
end case;
N := N.Next;
end loop;
if not NL then
Text_IO.New_Line;
end if;
end Print_Tree;
-------------
-- Release --
-------------
procedure Release (T : in out Tag_Var) is
use type Filter.Set_Access;
procedure Unchecked_Free is
new Ada.Unchecked_Deallocation (Filter.Set, Filter.Set_Access);
begin
if T.Filters /= null then
Filter.Release (T.Filters.all);
Unchecked_Free (T.Filters);
end if;
if T.Parameters /= null then
for K in T.Parameters'Range loop
Data.Release (T.Parameters (K));
end loop;
Data.Unchecked_Free (T.Parameters);
end if;
Release (T.Def, Include => False);
end Release;
procedure Release (D : in out Tree; Single : Boolean := False) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Node, Tree);
P : Tree;
T : Tree := D;
begin
while T /= null loop
P := T;
T := T.Next;
case P.Kind is
when Var => Release (P.Var);
when Text => null;
end case;
Unchecked_Free (P);
exit when Single;
end loop;
D := null;
end Release;
------------------------
-- To_Data_Parameters --
------------------------
function To_Data_Parameters
(Parameters : Templates_Parser.Parameter_Set) return Data.Parameters
is
P : constant Data.Parameters := new Parameter_Set (Parameters'Range);
begin
for K in P'Range loop
P (K) := Data.Parse (To_String (Parameters (K)), 0);
end loop;
return P;
end To_Data_Parameters;
---------------
-- Translate --
---------------
function Translate
(T : Tag_Var;
Value : String;
Context : not null access Filter.Filter_Context) return String
is
use type Filter.Set_Access;
begin
if T.Filters /= null then
declare
R : Unbounded_String := To_Unbounded_String (Value);
begin
for K in T.Filters'Range loop
R := To_Unbounded_String
(T.Filters (K).Handle
(To_String (R), Context, T.Filters (K).Parameters));
end loop;
return To_String (R);
end;
end if;
return Value;
end Translate;
end Data;