------------------------------------------------------------------------------ -- Templates Parser -- -- -- -- Copyright (C) 1999 - 2003 -- -- Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, 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. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- 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. -- ------------------------------------------------------------------------------ -- $Id: templates_parser.adb,v 1.3 2004/02/24 15:49:33 Jano Exp $ with Ada.Exceptions; with Ada.Characters.Handling; with Ada.Calendar; with Ada.IO_Exceptions; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with GNAT.Calendar.Time_IO; with GNAT.OS_Lib; with GNAT.Regexp; with Templates_Parser.Input; with Text_io; use Text_io; package body Templates_Parser is use Ada; use Ada.Exceptions; use Ada.Strings; Internal_Error : exception; Blank : constant Maps.Character_Set := Maps.To_Set (' ' & ASCII.HT); function Image (N : in Integer) return String; pragma Inline (Image); -- Returns N image without leading blank function No_Quote (Str : in String) return String; -- Removes quotes around Str. If Str (Str'First) and Str (Str'Last) -- are quotes return Str (Str'First + 1 .. Str'Last - 1) otherwise -- return Str as-is. ----------- -- Image -- ----------- function Image (N : in Integer) return String is N_Img : constant String := Integer'Image (N); begin if N_Img (N_Img'First) = '-' then return N_Img; else return N_Img (N_Img'First + 1 .. N_Img'Last); end if; end Image; -------------- -- No_Quote -- -------------- function No_Quote (Str : in String) return String is begin if Str (Str'First) = '"' and then Str (Str'Last) = '"' then return Str (Str'First + 1 .. Str'Last - 1); else return Str; end if; end No_Quote; -------------- -- Tag Info -- -------------- Begin_Tag : Unbounded_String := To_Unbounded_String (Default_Begin_Tag); End_Tag : Unbounded_String := To_Unbounded_String (Default_End_Tag); Table_Token : constant String := "@@TABLE@@"; Terminate_Sections_Token : constant String := "@@TERMINATE_SECTIONS@@"; Section_Token : constant String := "@@SECTION@@"; End_Table_Token : constant String := "@@END_TABLE@@"; If_Token : constant String := "@@IF@@"; Elsif_Token : constant String := "@@ELSIF@@"; Else_Token : constant String := "@@ELSE@@"; End_If_Token : constant String := "@@END_IF@@"; Include_Token : constant String := "@@INCLUDE@@"; ------------ -- Filter -- ------------ package Filter is ---------------------- -- Filters setting -- ---------------------- -- A filter appear just before a tag variable (e.g. @_LOWER:SOME_VAR_@ -- and means that the filter LOWER should be applied to SOME_VAR before -- replacing it in the template file. type Mode is (Multiply, -- Multiply the given parameter to the string (operator "*") Plus, -- Add the given parameter to the string (operator "+") Minus, -- Substract the given parameter to the string (operator "-") Divide, -- Divide the given parameter to the string (operator "/") Add, -- Add the given parameter to the string BR_2_LF, -- Replaces all
HTML tag by a LF character. Capitalize, -- Lower case except char before spaces and underscores. Clean_Text, -- Only letter/digits all other chars are changed to spaces. Coma_2_Point, -- Replaces comas by points. Contract, -- Replaces a suite of spaces by a single space character. Div, -- Divide the given parameter to the string Exist, -- Returns "TRUE" if var is not empty and "FALSE" otherwise. Format_Number, -- Returns the number with a space added between each 3 digits -- blocks. The decimal part is not transformed. If the data is not a -- number nothing is done. The data is trimmed before processing it. Is_Empty, -- Returns "TRUE" if var is empty and "FALSE" otherwise. LF_2_BR, -- Replaces all LF character to
HTML tag. Lower, -- Lower case. Match, -- Returns "TRUE" if var match the pattern passed as argument. Modulo, -- Returns current value modulo N (N is the filter parameter) Mult, -- Multiply the given parameter to the string No_Digit, -- Replace all digits by spaces. No_Letter, -- Removes all letters by spaces. No_Space, -- Removes all spaces found in the value. Oui_Non, -- If True return Oui, If False returns Non, else do nothing. Point_2_Coma, -- Replaces points by comas. Repeat, -- Returns N copy of the original string. The number of copy is -- passed as parameter. Invert, -- Reverse string. Size, -- Returns the number of characters in the string value. Slice, -- Returns a slice of the string. Sub, -- Substract the given parameter to the string Trim, -- Trim leading and trailing space. Upper, -- Upper case. Web_Escape, -- Convert characters "<>&" to HTML equivalents: <, > and & Web_NBSP, -- Convert spaces to HTML   - non breaking spaces. Yes_No -- If True return Yes, If False returns No, else do nothing. ); type Parameter_Mode is (Void, Str, Regexp, Slice); function Parameter (Mode : in Filter.Mode) return Parameter_Mode; -- Returns the parameter mode for the given filter. type Parameter_Data (Mode : Parameter_Mode := Void) is record case Mode is when Void => null; when Str => S : Unbounded_String; when Regexp => R_Str : Unbounded_String; Regexp : GNAT.Regexp.Regexp; when Slice => First : Natural; Last : Natural; end case; end record; No_Parameter : constant Parameter_Data := Parameter_Data'(Mode => Void); function Image (P : in Parameter_Data) return String; -- Returns parameter string representation. type Callback is access function (S : in String; P : in Parameter_Data := No_Parameter) return String; -- P is the filter parameter, no parameter by default. Parameter are -- untyped and will be parsed by the filter function if needed. type Routine is record Handle : Callback; Parameters : Parameter_Data; end record; type Set is array (Positive range <>) of Routine; type Set_Access is access Set; type String_Access is access constant String; type Filter_Record is record Name : String_Access; Handle : Callback; end record; -- filter functions, see above. procedure Check_Null_Parameter (P : in Parameter_Data); -- Raises Template_Error if P is not equal to Null_Parameter. function BR_2_LF (S : in String; P : in Parameter_Data := No_Parameter) return String; function Capitalize (S : in String; P : in Parameter_Data := No_Parameter) return String; function Clean_Text (S : in String; P : in Parameter_Data := No_Parameter) return String; function Coma_2_Point (S : in String; P : in Parameter_Data := No_Parameter) return String; function Contract (S : in String; P : in Parameter_Data := No_Parameter) return String; function Exist (S : in String; P : in Parameter_Data := No_Parameter) return String; function Format_Number (S : in String; P : in Parameter_Data := No_Parameter) return String; function Is_Empty (S : in String; P : in Parameter_Data := No_Parameter) return String; function LF_2_BR (S : in String; P : in Parameter_Data := No_Parameter) return String; function Lower (S : in String; P : in Parameter_Data := No_Parameter) return String; function Match (S : in String; P : in Parameter_Data := No_Parameter) return String; function No_Digit (S : in String; P : in Parameter_Data := No_Parameter) return String; function No_Letter (S : in String; P : in Parameter_Data := No_Parameter) return String; function No_Space (S : in String; P : in Parameter_Data := No_Parameter) return String; function Oui_Non (S : in String; P : in Parameter_Data := No_Parameter) return String; function Point_2_Coma (S : in String; P : in Parameter_Data := No_Parameter) return String; function Repeat (S : in String; P : in Parameter_Data := No_Parameter) return String; function Reverse_Data (S : in String; P : in Parameter_Data := No_Parameter) return String; function Size (S : in String; P : in Parameter_Data := No_Parameter) return String; function Slice (S : in String; P : in Parameter_Data := No_Parameter) return String; function Trim (S : in String; P : in Parameter_Data := No_Parameter) return String; function Upper (S : in String; P : in Parameter_Data := No_Parameter) return String; function Web_Escape (S : in String; P : in Parameter_Data := No_Parameter) return String; function Web_NBSP (S : in String; P : in Parameter_Data := No_Parameter) return String; function Yes_No (S : in String; P : in Parameter_Data := No_Parameter) return String; function Plus (S : in String; P : in Parameter_Data := No_Parameter) return String; function Minus (S : in String; P : in Parameter_Data := No_Parameter) return String; function Divide (S : in String; P : in Parameter_Data := No_Parameter) return String; function Multiply (S : in String; P : in Parameter_Data := No_Parameter) return String; function Modulo (S : in String; P : in Parameter_Data := No_Parameter) return String; function Handle (Name : in String) return Callback; -- Returns the filter function for the given filter name. function Handle (Mode : in Filter.Mode) return Callback; -- Returns the filter function for the given filter mode. function Mode_Value (Name : in String) return Mode; -- Returns the Mode for filter named Name. This is the internal -- representation for this filter name. function Name (Handle : in Callback) return String; -- Returns the filter name for the given filter function. end Filter; -------------------- -- Tags variable -- -------------------- type Attribute is (Nil, Length, Line, Min_Column, Max_Column); type Tag is record Name : Unbounded_String; Filters : Filter.Set_Access; Attr : Attribute := Nil; end record; function Build (Str : in String) return Tag; -- Create a Tag from Str. A tag is composed of a name and a set of -- filters. function Image (T : in Tag) return String; -- Returns string representation for the Tag variable. function Translate (T : in Tag; Value : in String) return String; -- Returns the result of Value after applying all filters for tag T. procedure Release (T : in out Tag); -- Release all memory associated with Tag. ----------- -- Image -- ----------- function Image (T : in Tag) return String is use type Filter.Set_Access; R : Unbounded_String; 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); -- Attributes case T.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"); end case; Append (R, End_Tag); return To_String (R); end Image; ----------- -- Build -- ----------- function Build (Str : in String) return Tag is function Get_Var_Name (Tag : in String) return Unbounded_String; -- Given a Tag name, it returns the variable name only. It removes -- the tag separator and the filters. function Get_Filter_Set (Tag : in 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 : in String) return Attribute; -- Returns attribute for the given tag. F_Sep : constant Natural := Strings.Fixed.Index (Str, ":", Strings.Backward); -- Last filter separator A_Sep : constant Natural := Strings.Fixed.Index (Str, "'", Strings.Backward); -- Attribute separator ------------------- -- Get_Attribute -- ------------------- function Get_Attribute (Tag : in String) return Attribute is Start, Stop : Natural; begin if A_Sep = 0 then return Nil; 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; elsif A_Name = "line" then return Line; elsif A_Name = "min_column" then return Min_Column; elsif A_Name = "max_column" then return Max_Column; else Exceptions.Raise_Exception (Template_Error'Identity, "Unknown attribute name """ & A_Name & '"'); end if; end; end Get_Attribute; -------------------- -- Get_Filter_Set -- -------------------- function Get_Filter_Set (Tag : in String) return Filter.Set_Access is Start : Natural; Stop : Natural := Tag'Last; FS : Filter.Set (1 .. Strings.Fixed.Count (Tag, ":")); K : Positive := FS'First; function Name_Parameter (Filter : in String) return Templates_Parser.Filter.Routine; -- Given a Filter description, returns the filter handle and -- parameter. procedure Get_Slice (Slice : in String; First, Last : out Natural); -- Returns the First and Last slice index as parsed into the Slice -- string. Retruns First and Last set to 0 if there is not valid -- slice definition in Slice. --------------- -- Get_Slice -- --------------- procedure Get_Slice (Slice : in String; First, Last : out Natural) is P1 : constant Natural := Fixed.Index (Slice, ".."); begin First := 0; Last := 0; if P1 = 0 then Exceptions.Raise_Exception (Template_Error'Identity, "slice expected """ & Slice & '"'); else First := Natural'Value (Slice (Slice'First .. P1 - 1)); Last := Natural'Value (Slice (P1 + 2 .. Slice'Last)); end if; end Get_Slice; -------------------- -- Name_Parameter -- -------------------- function Name_Parameter (Filter : in String) return Templates_Parser.Filter.Routine is use Strings; package F renames Templates_Parser.Filter; 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 Exceptions.Raise_Exception (Template_Error'Identity, "unbalanced parenthesis """ & Filter & '"'); elsif P2 /= 0 and then P2 < Filter'Last and then Filter (P2 + 1) /= ':' then Exceptions.Raise_Exception (Template_Error'Identity, "unexpected character after parenthesis """ & Filter & '"'); end if; if P1 = 0 then -- No parenthesis, so there is no parameter to parse return (F.Handle (Filter), F.Parameter_Data'(Mode => F.Void)); else declare 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, To_Unbounded_String (Parameter), GNAT.Regexp.Compile (Parameter))); when F.Slice => declare First, Last : Natural; 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, To_Unbounded_String (Parameter))); when F.Void => pragma Warnings (Off); null; end case; end; end if; end Name_Parameter; begin if FS'Length = 0 then return null; end if; loop Start := Tag'First; Stop := Strings.Fixed.Index (Tag (Start .. Stop), ":", Strings.Backward); exit when Stop = 0; Start := Strings.Fixed.Index (Tag (Start .. Stop - 1), ":", Strings.Backward); 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; K := K + 1; Stop := Stop - 1; end loop; return new Filter.Set'(FS); end Get_Filter_Set; ------------------ -- Get_Var_Name -- ------------------ function Get_Var_Name (Tag : in String) return Unbounded_String is Start, Stop : Natural; begin if A_Sep = 0 then -- No attribute Stop := Tag'Last - Length (End_Tag); 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 To_Unbounded_String (Tag (Start .. Stop)); end Get_Var_Name; begin return (Get_Var_Name (Str), Get_Filter_Set (Str), Get_Attribute (Str)); end Build; ------------- -- Release -- ------------- procedure Release (T : in out Tag) is procedure Free is new Ada.Unchecked_Deallocation (Filter.Set, Filter.Set_Access); begin Free (T.Filters); end Release; --------------- -- Translate -- --------------- function Translate (T : in Tag; Value : in String) 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), T.Filters (K).Parameters)); end loop; return To_String (R); end; end if; return Value; end Translate; ---------- -- Data -- ---------- package Data is type Node; type Tree is access Node; type NKind is (Text, Var); type Node (Kind : NKind) is record Next : Tree; case Kind is when Text => Value : Unbounded_String; when Var => Var : Tag; end case; end record; function Parse (Line : in String) return Tree; -- Parse text line and returns the corresponding tree representation. procedure Print_Tree (D : in Tree); -- Decend the text tree and print it to the standard output. procedure Release (D : in out Tree); -- Release all memory used by the tree. end Data; ------------------ -- Expressions -- ------------------ package Expr is type Ops is (O_And, O_Or, O_Xor, O_Sup, O_Inf, O_Esup, O_Einf, O_Equal, O_Diff); function Image (O : in Ops) return String; -- Returns Ops string representation. function Value (O : in String) return Ops; -- Returns Ops from its string representation. Raises Templates_Error if -- the token is not a known operation. type U_Ops is (O_Not); function Image (O : in U_Ops) return String; -- Returns U_Ops string representation. function Value (O : in String) return U_Ops; -- Returns U_Ops from its string representation. Raises Templates_Error -- if the token is not a known operation. type Node; type Tree is access Node; type NKind is (Value, Var, Op, U_Op); -- The node is a value, a variable a binary operator or an unary -- operator type Node (Kind : NKind) is record case Kind is when Value => V : Unbounded_String; when Var => Var : Tag; when Op => O : Ops; Left, Right : Tree; when U_Op => U_O : U_Ops; Next : Tree; end case; end record; function Parse (Expression : in String) return Tree; -- Parse Expression and returns the corresponding tree representation. procedure Print_Tree (E : in Tree); -- Decend the expression's tree and print the expression. It outputs the -- expression with all parenthesis to show without ambiguity the way the -- expression has been parsed. procedure Release (E : in out Tree); -- Release all associated memory with the tree. end Expr; -------------------------------- -- Template Tree definitions -- -------------------------------- type Nkind is (Info, -- first node is tree infos C_Info, -- second node is cache tree info Text, -- this is a text line If_Stmt, -- an IF tag statement Table_Stmt, -- a TABLE tag statement Section_Stmt, -- a TABLE section Include_Stmt); -- an INCLUDE tag statement -- A template line is coded as a suite of Data and Var element. -- The first node in the tree is of type Info and should never be release -- and changed. This ensure that included tree will always be valid -- otherwise will would have to parse all the current trees in the cache -- to update the reference. type Node; type Tree is access Node; -- Static_Tree represent a Tree immune to cache changes. Info point to the -- first node and C_Info to the second one. C_Info could be different to -- Info.Next in case of cache changes. This way we keep a pointer to the -- old tree to be able to release it when not used anymore. This way it is -- possible to use the cache in multitasking program without trouble. The -- changes in the cache are either because more than one task is parsing -- the same template at the same time, they will update the cache with the -- same tree at some point, or because a newer template was found in the -- file system. type Static_Tree is record Info : Tree; C_Info : Tree; end record; type Node (Kind : Nkind) is record Next : Tree; Line : Natural; case Kind is when Info => Filename : Unbounded_String; -- Name of the file Timestamp : GNAT.OS_Lib.OS_Time; -- Date and Time of last change I_File : Tree; -- Included file references -- Used for the cache system Ref : Natural := 0; -- Number of ref in the cache when C_Info => Obsolete : Boolean := False; -- True if newer version in cache Used : Natural := 0; -- >0 if currently used when Text => Text : Data.Tree; when If_Stmt => Cond : Expr.Tree; N_True : Tree; N_False : Tree; when Table_Stmt => Terminate_Sections : Boolean; Sections : Tree; when Section_Stmt => N_Section : Tree; when Include_Stmt => File : Static_Tree; end case; end record; procedure Release (T : in out Tree); -- Release all memory associated with the tree. procedure Free is new Ada.Unchecked_Deallocation (Node, Tree); ------------------- -- Cached Files -- ------------------- -- Cached_Files keep the parsed Tree for a given file in memory. This -- implementation is thread safe so it is possible to use the cache in a -- multitasking program. package Cached_Files is protected Prot is procedure Add (Filename : in String; T : in Tree; Old : out Tree); -- Add Filename/T to the list of cached files. If Filename is -- already in the list, replace the current tree with T. Furthemore -- if Filename tree is already in use, Old will be set with the -- previous C_Info node otherwise Old will be T.Next (C_Info node -- for current tree). procedure Get (Filename : in String; Load : in Boolean; Result : out Static_Tree); -- Returns the Tree for Filename or null if Filename has not been -- cached. Load must be set to True at load stage and False at Parse -- stage. procedure Release (T : in out Static_Tree); -- After loading a tree and using it, it is required that it be -- released. This will ensure that a tree marked as obsolete (a new -- version being now in the cache) will be released from the memory. end Prot; end Cached_Files; ---------------- -- Vector_Tag -- ---------------- procedure Field (Vect : in Vector_Tag; N : in Positive; Result : out Unbounded_String; Found : out Boolean); -- Returns the Nth value in the vector tag. Found is set to False if -- N > Vect_Value'Last. --------- -- "+" -- --------- function "+" (Value : in String) return Vector_Tag is Item : constant Vector_Tag_Node_Access := new Vector_Tag_Node'(To_Unbounded_String (Value), null); begin return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => new Integer'(1), Count => 1, Head => Item, Last => Item, Current => new Vector_Tag_Node_Access'(Item), Pos => new Integer'(1)); end "+"; function "+" (Value : in Character) return Vector_Tag is begin return +String'(1 => Value); end "+"; function "+" (Value : in Boolean) return Vector_Tag is begin return +Boolean'Image (Value); end "+"; function "+" (Value : in Strings.Unbounded.Unbounded_String) return Vector_Tag is begin return +To_String (Value); end "+"; function "+" (Value : in Integer) return Vector_Tag is begin return +Image (Value); end "+"; --------- -- "&" -- --------- function "&" (Vect : in Vector_Tag; Value : in String) return Vector_Tag is Item : constant Vector_Tag_Node_Access := new Vector_Tag_Node'(To_Unbounded_String (Value), null); begin Vect.Ref_Count.all := Vect.Ref_Count.all + 1; if Vect.Count = 0 then return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => Vect.Ref_Count, Count => 1, Head => Item, Last => Item, Current => new Vector_Tag_Node_Access'(Item), Pos => Vect.Pos); else Vect.Last.Next := Item; return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => Vect.Ref_Count, Count => Vect.Count + 1, Head => Vect.Head, Last => Item, Current => Vect.Current, Pos => Vect.Pos); end if; end "&"; function "&" (Vect : in Vector_Tag; Value : in Character) return Vector_Tag is begin return Vect & String'(1 => Value); end "&"; function "&" (Vect : in Vector_Tag; Value : in Boolean) return Vector_Tag is begin return Vect & Boolean'Image (Value); end "&"; function "&" (Vect : in Vector_Tag; Value : in Strings.Unbounded.Unbounded_String) return Vector_Tag is begin return Vect & To_String (Value); end "&"; function "&" (Vect : in Vector_Tag; Value : in Integer) return Vector_Tag is begin return Vect & Image (Value); end "&"; ----------- -- Clear -- ----------- procedure Clear (Vect : in out Vector_Tag) is begin -- Here we just separate current vector from the new one. The memory -- used by the current one will be collected by the Finalize -- routine. We just want a new independant Vector_Tag here. Finalize (Vect); Vect.Ref_Count := new Integer'(1); Vect.Pos := new Integer'(1); Vect.Count := 0; Vect.Head := null; Vect.Last := null; Vect.Current := null; end Clear; ------------ -- Adjust -- ------------ procedure Adjust (V : in out Vector_Tag) is begin V.Ref_Count.all := V.Ref_Count.all + 1; end Adjust; ---------------- -- Initialize -- ---------------- procedure Initialize (V : in out Vector_Tag) is begin V.Ref_Count := new Integer'(1); V.Pos := new Integer'(1); V.Count := 0; end Initialize; ---------- -- Item -- ---------- function Item (Vect : in Vector_Tag; N : in Positive) return String is Result : Unbounded_String; Found : Boolean; begin Field (Vect, N, Result, Found); if not Found then raise Constraint_Error; else return To_String (Result); end if; end Item; -------------- -- Finalize -- -------------- procedure Finalize (V : in out Vector_Tag) is begin V.Ref_Count.all := V.Ref_Count.all - 1; if V.Ref_Count.all = 0 then declare procedure Free is new Ada.Unchecked_Deallocation (Vector_Tag_Node, Vector_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Vector_Tag_Node_Access, Access_Vector_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); P, N : Vector_Tag_Node_Access; begin P := V.Head; while P /= null loop N := P.Next; Free (P); P := N; end loop; V.Head := null; V.Last := null; Free (V.Ref_Count); Free (V.Pos); Free (V.Current); end; end if; end Finalize; ---------- -- Size -- ---------- function Size (Vect : in Vector_Tag) return Natural is begin return Vect.Count; end Size; ---------------- -- Matrix_Tag -- ---------------- procedure Field (Matrix : in Matrix_Tag; I, J : in Natural; Result : out Unbounded_String; Found : out Boolean); -- Returns Value in Mat_Value (I, J). Found is set to False if there is -- no such value in Mat_Value. procedure Vector (Matrix : in Matrix_Tag; N : in Positive; Vect : out Vector_Tag; Found : out Boolean); -- Returns Vect in Matrix (N). Found is set to False if there is no such -- vector in Matrix. --------- -- "+" -- --------- function "+" (Vect : in Vector_Tag) return Matrix_Tag is Item : constant Matrix_Tag_Node_Access := new Matrix_Tag_Node'(Vect, null); V_Size : constant Natural := Size (Vect); begin return Matrix_Tag' (M => (Ada.Finalization.Controlled with Ref_Count => New Integer'(1), Count => 1, Min => V_Size, Max => V_Size, Head => Item, Last => Item, Current => new Matrix_Tag_Node_Access'(Item), Pos => new Integer'(1))); end "+"; --------- -- "&" -- --------- function "&" (Matrix : in Matrix_Tag; Vect : in Vector_Tag) return Matrix_Tag is Item : constant Matrix_Tag_Node_Access := new Matrix_Tag_Node'(Vect, null); V_Size : constant Natural := Size (Vect); begin Matrix.M.Ref_Count.all := Matrix.M.Ref_Count.all + 1; if Matrix.M.Head = null then return (M => (Ada.Finalization.Controlled with Matrix.M.Ref_Count, Matrix.M.Count + 1, Min => Natural'Min (Matrix.M.Min, V_Size), Max => Natural'Max (Matrix.M.Max, V_Size), Head => Item, Last => Item, Current => new Matrix_Tag_Node_Access'(Item), Pos => Matrix.M.Pos)); else Matrix.M.Last.Next := Item; return (M => (Ada.Finalization.Controlled with Matrix.M.Ref_Count, Matrix.M.Count + 1, Min => Natural'Min (Matrix.M.Min, V_Size), Max => Natural'Max (Matrix.M.Max, V_Size), Head => Matrix.M.Head, Last => Item, Current => Matrix.M.Current, Pos => Matrix.M.Pos)); end if; end "&"; ---------- -- Size -- ---------- function Size (Matrix : in Matrix_Tag) return Natural is begin return Matrix.M.Count; end Size; ---------------- -- Initialize -- ---------------- procedure Initialize (M : in out Matrix_Tag_Int) is begin M.Ref_Count := new Integer'(1); M.Pos := new Integer'(1); M.Count := 0; M.Min := Natural'Last; M.Max := 0; end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (M : in out Matrix_Tag_Int) is begin M.Ref_Count.all := M.Ref_Count.all - 1; if M.Ref_Count.all = 0 then declare procedure Free is new Ada.Unchecked_Deallocation (Matrix_Tag_Node, Matrix_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Matrix_Tag_Node_Access, Access_Matrix_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); P, N : Matrix_Tag_Node_Access; begin P := M.Head; while P /= null loop N := P.Next; Free (P); P := N; end loop; M.Head := null; M.Last := null; Free (M.Ref_Count); Free (M.Pos); Free (M.Current); end; end if; end Finalize; ------------ -- Adjust -- ------------ procedure Adjust (M : in out Matrix_Tag_Int) is begin M.Ref_Count.all := M.Ref_Count.all + 1; end Adjust; ------------ -- Vector -- ------------ procedure Vector (Matrix : in Matrix_Tag; N : in Positive; Vect : out Vector_Tag; Found : out Boolean) is begin Found := True; if N = Matrix.M.Count then Vect := Matrix.M.Last.Vect; elsif N >= Matrix.M.Pos.all then for K in 1 .. N - Matrix.M.Pos.all loop Matrix.M.Pos.all := Matrix.M.Pos.all + 1; Matrix.M.Current.all := Matrix.M.Current.all.Next; end loop; Vect := Matrix.M.Current.all.Vect; elsif N > Matrix.M.Count then Found := False; else declare P : Matrix_Tag_Node_Access := Matrix.M.Head; begin for K in 1 .. N - 1 loop P := P.Next; end loop; Matrix.M.Pos.all := N; Matrix.M.Current.all := P; Vect := P.Vect; end; end if; end Vector; function Vector (Matrix : in Matrix_Tag; N : in Positive) return Vector_Tag is Result : Vector_Tag; Found : Boolean; begin Vector (Matrix, N, Result, Found); if Found then return Result; else Exceptions.Raise_Exception (Constraint_Error'Identity, "Index out of range"); end if; end Vector; ------------------ -- Cached_Files -- ------------------ package body Cached_Files is separate; ---------- -- Data -- ---------- package body Data is separate; ---------- -- Expr -- ---------- package body Expr is separate; ----------- -- Field -- ----------- procedure Field (Vect : in Vector_Tag; N : in Positive; Result : out Unbounded_String; Found : out Boolean) is begin Found := True; if N = Vect.Count then Result := Vect.Last.Value; elsif N > Vect.Count then Result := Null_Unbounded_String; Found := False; elsif N >= Vect.Pos.all then for K in 1 .. N - Vect.Pos.all loop Vect.Pos.all := Vect.Pos.all + 1; Vect.Current.all := Vect.Current.all.Next; end loop; Result := Vect.Current.all.Value; else declare P : Vector_Tag_Node_Access := Vect.Head; begin for K in 1 .. N - 1 loop P := P.Next; end loop; Vect.Pos.all := N; Vect.Current.all := P; Result := P.Value; end; end if; end Field; procedure Field (Matrix : in Matrix_Tag; I, J : in Natural; Result : out Unbounded_String; Found : out Boolean) is begin Found := True; if I = Matrix.M.Count then Field (Matrix.M.Last.Vect, J, Result, Found); elsif I > Matrix.M.Count then Result := Null_Unbounded_String; Found := False; elsif I >= Matrix.M.Pos.all then for K in 1 .. I - Matrix.M.Pos.all loop Matrix.M.Pos.all := Matrix.M.Pos.all + 1; Matrix.M.Current.all := Matrix.M.Current.all.Next; end loop; Field (Matrix.M.Current.all.Vect, J, Result, Found); else declare P : Matrix_Tag_Node_Access := Matrix.M.Head; begin for K in 1 .. I - 1 loop P := P.Next; end loop; Matrix.M.Pos.all := I; Matrix.M.Current.all := P; Field (P.Vect, J, Result, Found); end; end if; end Field; ------------ -- Filter -- ------------ package body Filter is separate; ----------- -- Assoc -- ----------- function Assoc (Variable : in String; Value : in String) return Association is begin return Association' (Std, To_Unbounded_String (Variable), To_Unbounded_String (Value)); end Assoc; function Assoc (Variable : in String; Value : in Ada.Strings.Unbounded.Unbounded_String) return Association is begin return Assoc (Variable, To_String (Value)); end Assoc; function Assoc (Variable : in String; Value : in Integer) return Association is S_Value : constant String := Integer'Image (Value); begin return Assoc (Variable, Image (Value)); end Assoc; function Assoc (Variable : in String; Value : in Boolean) return Association is begin if Value then return Assoc (Variable, "TRUE"); else return Assoc (Variable, "FALSE"); end if; end Assoc; function Assoc (Variable : in String; Value : in Vector_Tag; Separator : in String := Default_Separator) return Association is begin return Association' (Vect, To_Unbounded_String (Variable), Value, To_Unbounded_String (Separator)); end Assoc; function Assoc (Variable : in String; Value : in Matrix_Tag; Separator : in String := Default_Separator) return Association is begin return Association' (Matrix, To_Unbounded_String (Variable), Value, To_Unbounded_String (Separator)); end Assoc; ---------- -- Load -- ---------- function Load (Filename : in String; Cached : in Boolean := False; Include_File : in Boolean := False) return Static_Tree is File : Input.File_Type; -- file beeing parsed. Buffer : String (1 .. 2048); -- current line content Last : Natural; -- index of last characters read in buffer First : Natural; -- first non blank characters in buffer Line : Natural := 0; I_File : Tree; -- list of includes Error_Include_Filename : Unbounded_String; -- This variable will be set with the name of the include file that was -- not possible to load. -- Line handling procedure Fatal_Error (Message : in String); pragma No_Return (Fatal_Error); -- raise Template_Error exception with message. function Get_Next_Line return Boolean; -- Get new line in File and set Buffer, Last and First. Returns True if -- end of file reached. function Get_First_Parameter return Unbounded_String; -- Get first parameter in current line (second word), words beeing -- separated by a set of blank characters (space or horizontal -- tabulation). function Get_All_Parameters return String; -- Get all parameters on the current line. function Is_Stmt (Stmt : in String) return Boolean; pragma Inline (Is_Stmt); -- Returns True is Stmt is found at the begining of the current line -- ignoring leading blank characters. function EOF return Boolean; pragma Inline (EOF); -- Returns True if the end of file has been reach. function Build_Include_Pathname (Include_Filename : in Unbounded_String) return String; -- Returns the full pathname to the include file (Include_Filename). It -- returns Include_Filename if there is a pathname specified, or the -- pathname of the main template file as a prefix of the include -- filename. procedure Replace_Include_Variables (File : in out Static_Tree; Variables : in String); -- Parse the include tree and replace all include variables (numeric -- name) with the corresponding value in Variables (a set of space -- separated words). The first word in Variables is the include file -- name (variable 0), other words are the parameters (variable 1 .. N). type Parse_Mode is (Parse_Std, -- in standard line Parse_If, -- in a if statement Parse_Elsif, -- in elsif part of a if statement Parse_Else, -- in else part of a if statement Parse_Table, -- in a table statement Parse_Section, -- in new section Parse_Section_Content -- in section content ); function Parse (Mode : in Parse_Mode; No_Read : in Boolean := False) return Tree; -- Get a line in File and returns the Tree. ---------------------------- -- Build_Include_Pathname -- ---------------------------- function Build_Include_Pathname (Include_Filename : in Unbounded_String) return String is K : constant Natural := Index (Include_Filename, Maps.To_Set ("/\"), Going => Strings.Backward); begin if K = 0 then declare K : constant Natural := Fixed.Index (Filename, Maps.To_Set ("/\"), Going => Strings.Backward); begin if K = 0 then return To_String (Include_Filename); else return Filename (Filename'First .. K) & To_String (Include_Filename); end if; end; else return To_String (Include_Filename); end if; end Build_Include_Pathname; --------- -- EOF -- --------- function EOF return Boolean is begin return Last = 0; end EOF; ----------------- -- Fatal_Error -- ----------------- procedure Fatal_Error (Message : in String) is begin Exceptions.Raise_Exception (Template_Error'Identity, "In " & Filename & " at line" & Natural'Image (Line) & ' ' & Message & '.'); end Fatal_Error; ------------------------ -- Get_All_Parameters -- ------------------------ function Get_All_Parameters return String is Start : Natural; begin Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); if Start = 0 then Fatal_Error ("missing parameter"); end if; if Buffer (Last) = ASCII.CR then -- Last character is a DOS CR (certainly because the template -- file is in DOS format), ignore it as this is not part of the -- parameter. Last := Last - 1; end if; return Strings.Fixed.Trim (Buffer (Start .. Last), Strings.Both); end Get_All_Parameters; ------------------------- -- Get_First_Parameter -- ------------------------- function Get_First_Parameter return Unbounded_String is Start, Stop : Natural; begin Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); if Start = 0 then return Null_Unbounded_String; end if; Start := Strings.Fixed.Index (Buffer (Start .. Last), Blank, Outside); if Start = 0 then -- We have only spaces after the first word, there is no -- parameter in this case. return Null_Unbounded_String; end if; Stop := Strings.Fixed.Index (Buffer (Start .. Last), Blank); if Stop = 0 then Stop := Last; else Stop := Stop - 1; end if; return To_Unbounded_String (Buffer (Start .. Stop)); end Get_First_Parameter; ------------------- -- Get_Next_Line -- ------------------- function Get_Next_Line return Boolean is use type Maps.Character_Set; Skip_End : constant Maps.Character_Set := Blank or Maps.To_Set (ASCII.CR); begin if Input.End_Of_File (File) then Last := 0; return True; else Line := Line + 1; loop Input.Get_Line (File, Buffer, Last); exit when Buffer (Buffer'First .. Buffer'First + 3) /= "@@--"; if Input.End_Of_File (File) then -- We have reached the end of file, exit now. Last := 0; return True; end if; end loop; First := Strings.Fixed.Index (Buffer (1 .. Last), Blank, Outside); if First = 0 then -- There is only spaces on this line, this is an empty line -- we just have to skip it. Last := 0; return False; end if; Last := Strings.Fixed.Index (Buffer (1 .. Last), Skip_End, Outside, Strings.Backward); return False; end if; end Get_Next_Line; ------------- -- Is_Stmt -- ------------- function Is_Stmt (Stmt : in String) return Boolean is begin return Last /= 0 and then Buffer (First .. First + Stmt'Length - 1) = Stmt; end Is_Stmt; ----------- -- Parse -- ----------- function Parse (Mode : in Parse_Mode; No_Read : in Boolean := False) return Tree is T : Tree; begin if not No_Read and then (Mode /= Parse_Section and then Mode /= Parse_Elsif) then if Get_Next_Line then return null; end if; end if; case Mode is when Parse_Std => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found outside an @@IF@@ statement"); end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found outside a @@TABLE@@ statement"); end if; when Parse_If => if Is_Stmt (Else_Token) or else Is_Stmt (Elsif_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Elsif => if Is_Stmt (Else_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Else => if Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; if Is_Stmt (Elsif_Token) then Fatal_Error ("@@ELSIF@@ found after @@ELSE@@"); end if; when Parse_Section => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; T := new Node (Section_Stmt); T.Line := Line; T.Next := Parse (Parse_Section_Content); if Is_Stmt (End_Table_Token) then T.N_Section := null; elsif EOF then Fatal_Error ("EOF found, @@END_TABLE@@ expected"); else T.N_Section := Parse (Parse_Section); end if; return T; when Parse_Section_Content => if Is_Stmt (Section_Token) or else Is_Stmt (End_Table_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; when Parse_Table => if Is_Stmt (End_Table_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; end case; if Is_Stmt (If_Token) or else Is_Stmt (Elsif_Token) then T := new Node (If_Stmt); T.Line := Line; T.Cond := Expr.Parse (Get_All_Parameters); T.N_True := Parse (Parse_If); if Is_Stmt (End_If_Token) then T.N_False := null; elsif Is_Stmt (Elsif_Token) then T.N_False := Parse (Parse_Elsif); elsif EOF then Fatal_Error ("EOF found, @@END_IF@@ expected"); else T.N_False := Parse (Parse_Else); end if; T.Next := Parse (Mode); return T; elsif Is_Stmt (Table_Token) then T := new Node (Table_Stmt); T.Line := Line; T.Terminate_Sections := Get_First_Parameter = Terminate_Sections_Token; T.Sections := Parse (Parse_Section); T.Next := Parse (Mode); return T; elsif Is_Stmt (Include_Token) then T := new Node (Include_Stmt); T.Line := Line; begin T.File := Load (Build_Include_Pathname (Get_First_Parameter), Cached, True); exception when others => -- Error while parsing the include file, record this -- error. Let the parser exit properly from the recursion -- to be able to release properly the memory before -- raising an exception. Error_Include_Filename := Get_First_Parameter; Free (T); return null; end; -- Now we must replace the include parameters (if present) into -- the included file tree. Replace_Include_Variables (T.File, Get_All_Parameters); I_File := new Node'(Include_Stmt, I_File, Line, T.File); T.Next := Parse (Mode); return T; else declare Root, N : Tree; begin loop N := new Node (Text); if Root = null then Root := N; else T.Next := N; end if; T := N; T.Line := Line; if Input.LF_Terminated (File) and then (not Input.End_Of_File (File) or else Include_File) then -- Add a LF is the read line with terminated by a LF. Do -- not add this LF if we reach the end of file except for -- included files. T.Text := Data.Parse (Buffer (1 .. Last) & ASCII.LF); else T.Text := Data.Parse (Buffer (1 .. Last)); end if; if Get_Next_Line then -- Nothing more, returns the result now. return Root; end if; -- If this is a statement just call the parsing routine if Is_Stmt (If_Token) or else Is_Stmt (ElsIf_Token) or else Is_Stmt (Else_Token) or else Is_Stmt (End_If_Token) or else Is_Stmt (Include_Token) or else Is_Stmt (Table_Token) or else Is_Stmt (Section_Token) or else Is_Stmt (End_Table_Token) then T.Next := Parse (Mode, No_Read => True); return Root; end if; end loop; end; end if; end Parse; ------------------------------- -- Replace_Include_Variables -- ------------------------------- procedure Replace_Include_Variables (File : in out Static_Tree; Variables : in String) is procedure Replace (T : in out Tree); -- Recursive routine to parse the tree for all Data.Tree node procedure Replace (T : in out Data.Tree); -- Recursive routine that replace all numeric variables by the -- corresponding parameter in Variables. function Get_Variable (Tag : in String) return String; -- Returns the variable name for the include tag Tag. Tag is a -- numeric value and represent the Nth include parameter. function Is_Number (Name : in String) return Boolean; -- Returns True if Name is an include tag variable ($) ------------------ -- Get_Variable -- ------------------ function Get_Variable (Tag : in String) return String is T : constant Natural := Natural'Value (Tag (Tag'First + 1 .. Tag'Last)); S : Natural := Variables'First; E : Natural; K : Natural := 0; begin loop if Variables (S) = '"' then -- Search for the ending quote E := Strings.Fixed.Index (Variables (S + 1 .. Variables'Last), """"); if E = 0 then Fatal_Error ("Missing quote"); else E := E + 1; end if; else -- Search for the next separator E := Strings.Fixed.Index (Variables (S .. Variables'Last), Blank); end if; if E = 0 and then K /= T then -- Not found, return the original tag name return To_String (Begin_Tag) & Tag & To_String (End_Tag); elsif K = T then -- We have found the right variable if E = 0 then E := Variables'Last; else E := E - 1; end if; -- Always return the variable or value unquoted if Variables (S) = '"' then return Variables (S + 1 .. E - 1); else return Variables (S .. E); end if; else -- Set the new start S := E; S := Strings.Fixed.Index (Variables (S .. Variables'Last), Blank, Strings.Outside); if S = 0 then -- No more values, return the original tag name return To_String (Begin_Tag) & Tag & To_String (End_Tag); end if; end if; K := K + 1; end loop; end Get_Variable; --------------- -- Is_Number -- --------------- function Is_Number (Name : in String) return Boolean is begin return Name'Length > 1 and then Name (Name'First) = '$' and then Strings.Fixed.Count (Name, Strings.Maps.Constants.Decimal_Digit_Set) = Name'Length - 1; end Is_Number; ------------- -- Replace -- ------------- procedure Replace (T : in out Data.Tree) is use type Data.NKind; use type Data.Tree; use type Filter.Set_Access; procedure Free is new Ada.Unchecked_Deallocation (Data.Node, Data.Tree); Old : Data.Tree := T; begin if T /= null then if T.Kind = Data.Var then if Is_Number (To_String (T.Var.Name)) then -- Here we have an include variable name, replace it T := Data.Parse (Get_Variable (To_String (T.Var.Name))); T.Next := Old.Next; case T.Kind is when Data.Var => -- The new node is also a variable, inherit all the -- filters and attribute T.Var.Filters := Old.Var.Filters; T.Var.Attr := Old.Var.Attr; when Data.Text => -- The new node is a value, apply filters if the -- previous node had some. if Old.Var.Filters /= null then T.Value := To_Unbounded_String (Translate (Old.Var, To_String (T.Value))); end if; -- Free filters Release (Old.Var); end case; -- Free only node Free (Old); end if; end if; Replace (T.Next); end if; end Replace; ------------- -- Replace -- ------------- procedure Replace (T : in out Expr.Tree) is use type Expr.NKind; use type Expr.Tree; use type Filter.Set_Access; procedure Free is new Ada.Unchecked_Deallocation (Expr.Node, Expr.Tree); Old : Expr.Tree := T; begin if T /= null then case T.Kind is when Expr.Var => if Is_Number (To_String (T.Var.Name)) then -- Here we have an include variable name, replace it declare New_Value : constant String := Get_Variable (To_String (T.Var.Name)); begin if Strings.Fixed.Index (New_Value, " ") = 0 then T := Expr.Parse (New_Value); else -- There is some spaces in the new value, -- this can't be a variable so it is a value -- with multiple word, quote it to ensure a -- correct parsing. T := Expr.Parse ('"' & New_Value & '"'); end if; end; case T.Kind is when Expr.Var => -- The new node is also a variable, inherit all -- the filters. T.Var.Filters := Old.Var.Filters; T.Var.Attr := Old.Var.Attr; when Expr.Value => -- The new node is a value, apply filters if the -- previous node had some. if Old.Var.Filters /= null then T.V := To_Unbounded_String (Translate (Old.Var, To_String (T.V))); end if; -- Free filters Release (Old.Var); when Expr.Op | Expr.U_Op => -- Should never happen Fatal_Error ("Var or Value node kind expected," & " Op or U_Op found "); end case; Free (Old); end if; when Expr.Op => Replace (T.Left); Replace (T.Right); when Expr.U_Op => Replace (T.Next); when Expr.Value => null; end case; end if; end Replace; ------------- -- Replace -- ------------- procedure Replace (T : in out Tree) is use type Tree; begin if T /= null then case T.Kind is when Text => Replace (T.Text); when If_Stmt => Replace (T.Cond); Replace (T.N_True); Replace (T.N_False); when Table_Stmt => Replace (T.Sections); when Include_Stmt => Replace (T.File.C_Info); when Section_Stmt => Replace (T.N_Section); when Info | C_Info => null; end case; Replace (T.Next); end if; end Replace; begin Replace (File.C_Info); end Replace_Include_Variables; T : Static_Tree; New_T : Tree; Old : Tree; begin if Cached then Cached_Files.Prot.Get (Filename, Load => True, Result => T); if T.Info /= null then pragma Assert (T.C_Info /= null); return T; end if; end if; Input.Open (File, Filename, Form => "shared=no"); New_T := Parse (Parse_Std); Input.Close (File); -- T is the tree file, add two nodes (Info and C_Info) in front of the -- tree. -- Add second node (cache info) Old := new Node'(C_Info, New_T, 0, False, 1); -- Add first node (info about tree) New_T := new Node'(Info, Old, 0, To_Unbounded_String (Filename), GNAT.OS_Lib.File_Time_Stamp (Filename), I_File, 1); if Error_Include_Filename /= Null_Unbounded_String then -- An include filename was not found, release the memory now and -- raise a fatal error. Release (New_T); Fatal_Error (To_String (Error_Include_Filename) & " include file missing"); end if; if Cached then Cached_Files.Prot.Add (Filename, New_T, Old); pragma Assert (Old /= null); end if; return Static_Tree'(New_T, Old); exception when E : Internal_Error => Fatal_Error (Exceptions.Exception_Message (E)); end Load; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (T : in Tree; Level : in Natural := 0) is separate; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (Filename : in String) is T : Static_Tree; begin T := Load (Filename); Print_Tree (T.Info); Release (T.Info); end Print_Tree; ----------- -- Parse -- ----------- function Parse (Filename : in String; Translations : in Translate_Table := No_Translation; Cached : in Boolean := False; Keep_Unknown_Tags : in Boolean := False) return String is begin return To_String (Parse (Filename, Translations, Cached, Keep_Unknown_Tags)); end Parse; ----------- -- Parse -- ----------- function Parse (Filename : in String; Translations : in Translate_Table := No_Translation; Cached : in Boolean := False; Keep_Unknown_Tags : in Boolean := False) return Unbounded_String is type Table_State is record I, J : Natural; Max_Lines : Natural; Max_Expand : Natural; Table_Level : Natural; Section_Number : Natural; end record; Empty_State : constant Table_State := (0, 0, 0, 0, 0, 0); Results : Unbounded_String := Null_Unbounded_String; Buffer : String (1 .. 4 * 1_024); Last : Natural := 0; -- Cache to avoid too many reallocation using Append on Results above Now : Calendar.Time; procedure Analyze (T : in Tree; State : in Table_State); -- Parse T and build results file. State is needed for Vector_Tag and -- Matrix_Tag expansion. ------------- -- Analyze -- ------------- procedure Analyze (T : in Tree; State : in Table_State) is function Analyze (E : in Expr.Tree) return String; -- Analyse the expression tree and returns the result as a boolean -- The conditional expression must be equal to either TRUE or -- FALSE. Note that a string is True if it is equal to string "TRUE" -- and False otherwise. procedure Analyze (D : in Data.Tree); -- Analyse the data tree and replace all variables by the -- correspinding value specified in Translations. This procedure -- catenate the result into Results variable. procedure Get_Max (T : in Tree; Max_Lines : out Natural; Max_Expand : out Natural); -- Returns the maximum number of lines (Max_Lines) into the -- table. This correspond to the length of the shortest vector tag -- into the table or the shortest number of lines in sub-table -- matrix tag. -- Returns also the number of time the table will be expanded -- (Max_Expand), this is equal to Max_Lines + offset to terminate -- the sections. function Is_True (Str : in String) return Boolean; -- Return True if Str is one of "TRUE", "OUI", the case beeing not -- case sensitive. function Translate (Var : in Tag) return String; -- Translate Tag variable using Translation table and apply all -- Filters and Atribute recorded for this variable. --------------- -- Translate -- --------------- function Translate (Var : in Tag) return String is function Vect_List (A : in Association) return String; -- Returns the Vector_Tag for the Association as a String, each -- value is separated by the given separator. function Vect_Size (A : in Association) return String; pragma Inline (Vect_Size); -- Returns the number of items into the Vector_Tag function Mat_List (A : in Association) return String; -- Returns the Matrix_Tag as a string. If Matrix_Tag is not into -- a table, each Vector_Tag is convected using Vect_List and a LF -- is inserted between each rows. If the Matrix_Tag is into a -- table of level 1, it returns only the Vector_Tag (converted -- using Vect_List) for the current table line. function Mat_Line (A : in Association) return String; pragma Inline (Mat_Line); -- Returns the number of line (vector) into the matrix function Mat_Min_Column (A : in Association) return String; pragma Inline (Mat_Line); -- Returns the size of the smallest vector function Mat_Max_Column (A : in Association) return String; pragma Inline (Mat_Line); -- Returns the size of the largest vector --------------- -- Vect_List -- --------------- function Vect_List (A : in Association) return String is Result : Unbounded_String; P : Vector_Tag_Node_Access := A.Vect_Value.Head; begin if P = null then return ""; else Result := P.Value; for K in 2 .. A.Vect_Value.Count loop P := P.Next; Append (Result, A.Separator & P.Value); end loop; return To_String (Result); end if; end Vect_List; --------------- -- Vect_Size -- --------------- function Vect_Size (A : in Association) return String is begin return Image (A.Vect_Value.Count); end Vect_Size; -------------- -- Mat_List -- -------------- function Mat_List (A : in Association) return String is Result : Unbounded_String; P : Matrix_Tag_Node_Access := A.Mat_Value.M.Head; procedure Add_Vector (V : in Vector_Tag); -- Add V Vector_Tag representation into Result variable. ---------------- -- Add_Vector -- ---------------- procedure Add_Vector (V : in Vector_Tag) is P : Vector_Tag_Node_Access := V.Head; begin -- Check that vector is not empty if P /= null then Result := Result & P.Value; for K in 2 .. V.Count loop P := P.Next; Append (Result, A.Column_Separator & P.Value); end loop; end if; end Add_Vector; begin if State.Table_Level = 0 then -- A Matrix outside a table statement. loop Add_Vector (P.Vect); P := P.Next; exit when P = null; Append (Result, ASCII.LF); end loop; else if not (State.J > A.Mat_Value.M.Count) then Add_Vector (Vector (A.Mat_Value, State.J)); end if; end if; return To_String (Result); end Mat_List; -------------- -- Mat_Line -- -------------- function Mat_Line (A : in Association) return String is begin return Image (A.Mat_Value.M.Count); end Mat_Line; -------------------- -- Mat_Min_Column -- -------------------- function Mat_Min_Column (A : in Association) return String is begin return Image (A.Mat_Value.M.Min); end Mat_Min_Column; -------------------- -- Mat_Max_Column -- -------------------- function Mat_Max_Column (A : in Association) return String is begin return Image (A.Mat_Value.M.Max); end Mat_Max_Column; begin for K in Translations'Range loop if Var.Name = Translations (K).Variable then declare Tk : constant Association := Translations (K); begin case Tk.Kind is when Std => if Var.Attr = Nil then return Translate (Var, To_String (Tk.Value)); else Exceptions.Raise_Exception (Template_Error'Identity, "Attribute not valid on a discrete tag"); end if; when Vect => if Var.Attr = Length then -- 'Length on a vector return Translate (Var, Vect_Size (Tk)); elsif Var.Attr /= Nil then Exceptions.Raise_Exception (Template_Error'Identity, "This attribute is not valid for a " & "vector tag"); elsif State.Table_Level = 0 then -- This is a vector tag (outside of a -- table tag statement), we display it as -- a list separated by the specified -- separator. return Translate (Var, Vect_List (Tk)); else declare Result : Unbounded_String; Found : Boolean; begin Field (Tk.Vect_Value, State.J, Result, Found); return Translate (Var, To_String (Result)); end; end if; when Matrix => if Var.Attr = Line then -- 'Line on a matrix return Translate (Var, Mat_Line (Tk)); elsif Var.Attr = Min_Column then -- 'Min_Column on a matrix return Translate (Var, Mat_Min_Column (Tk)); elsif Var.Attr = Max_Column then -- 'Max_Column on a matrix return Translate (Var, Mat_Max_Column (Tk)); elsif Var.Attr /= Nil then Exceptions.Raise_Exception (Template_Error'Identity, "This attribute is not valid for a " & "matrix tag"); elsif State.Table_Level in 0 .. 1 then -- This is a matrix tag (outside of a -- level 2 table tag statement), convert -- it using Mat_List. return Translate (Var, Mat_List (Tk)); else declare Result : Unbounded_String; Found : Boolean; begin Field (Tk.Mat_Value, State.I, State.J, Result, Found); return Translate (Var, To_String (Result)); end; end if; end case; end; end if; end loop; -- Check now for an internal tag declare T_Name : constant String := To_String (Var.Name); begin if T_Name = "UP_TABLE_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.I), Strings.Left)); elsif T_Name = "TABLE_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.J), Strings.Left)); elsif T_Name = "NUMBER_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.Max_Lines), Strings.Left)); elsif T_Name = "TABLE_LEVEL" then return Translate (Var, Fixed.Trim (Positive'Image (State.Table_Level), Strings.Left)); elsif T_Name = "YEAR" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%Y")); elsif T_Name = "MONTH" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%m")); elsif T_Name = "DAY" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%d")); elsif T_Name = "HOUR" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%H")); elsif T_Name = "MINUTE" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%M")); elsif T_Name = "SECOND" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%S")); elsif T_Name = "MONTH_NAME" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%B")); elsif T_Name = "DAY_NAME" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%A")); end if; end; -- The tag was not found in the Translation_Table, we either -- returns the empty string or we keep the tag as is. if Keep_Unknown_Tags then return To_String (Begin_Tag & Var.Name & End_Tag); else return Translate (Var, ""); end if; end Translate; ------------- -- Analyze -- ------------- procedure Analyze (D : in Data.Tree) is use type Data.Tree; procedure Add (S : in String); -- Add S into Results (using Buffer cache if possible) --------- -- Add -- --------- procedure Add (S : in String) is begin if Last + S'Length > Buffer'Last then -- Not enough cache space, flush buffer Append (Results, Buffer (1 .. Last)); Last := 0; end if; if S'Length >= Buffer'Length then Append (Results, S); else Buffer (Last + 1 .. Last + S'Length) := S; Last := Last + S'Length; end if; end Add; T : Data.Tree := D; begin while T /= null loop case T.Kind is when Data.Text => Add (To_String (T.Value)); when Data.Var => Add (Translate (T.Var)); end case; T := T.Next; end loop; end Analyze; ------------- -- Analyze -- ------------- function Analyze (E : in Expr.Tree) return String is type Ops_Fct is access function (L, R : in String) return String; function F_And (L, R : in String) return String; function F_Or (L, R : in String) return String; function F_Xor (L, R : in String) return String; function F_Sup (L, R : in String) return String; function F_Esup (L, R : in String) return String; function F_Einf (L, R : in String) return String; function F_Inf (L, R : in String) return String; function F_Equ (L, R : in String) return String; function F_Diff (L, R : in String) return String; type U_Ops_Fct is access function (N : in String) return String; function F_Not (N : in String) return String; ----------- -- F_And -- ----------- function F_And (L, R : in String) return String is begin if Is_True (L) and Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_And; ------------ -- F_Diff -- ------------ function F_Diff (L, R : in String) return String is begin if L /= R then return "TRUE"; else return "FALSE"; end if; end F_Diff; ------------ -- F_Einf -- ------------ function F_Einf (L, R : in String) return String is begin if Integer'Value (L) <= Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L <= R then return "TRUE"; else return "FALSE"; end if; end F_Einf; ----------- -- F_Equ -- ----------- function F_Equ (L, R : in String) return String is begin if L = R then return "TRUE"; else return "FALSE"; end if; end F_Equ; ------------ -- F_Esup -- ------------ function F_Esup (L, R : in String) return String is begin if Integer'Value (L) >= Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L >= R then return "TRUE"; else return "FALSE"; end if; end F_Esup; ----------- -- F_Inf -- ----------- function F_Inf (L, R : in String) return String is begin if Integer'Value (L) < Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L < R then return "TRUE"; else return "FALSE"; end if; end F_Inf; ----------- -- F_Not -- ----------- function F_Not (N : in String) return String is begin if Is_True (N) then return "FALSE"; else return "TRUE"; end if; end F_Not; ---------- -- F_Or -- ---------- function F_Or (L, R : in String) return String is begin if Is_True (L) or Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_Or; ----------- -- F_Sup -- ----------- function F_Sup (L, R : in String) return String is begin if Integer'Value (L) > Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L > R then return "TRUE"; else return "FALSE"; end if; end F_Sup; ----------- -- F_Xor -- ----------- function F_Xor (L, R : in String) return String is begin if Is_True (L) xor Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_Xor; Op_Table : constant array (Expr.Ops) of Ops_Fct := (Expr.O_And => F_And'Access, Expr.O_Or => F_Or'Access, Expr.O_Xor => F_Xor'Access, Expr.O_Sup => F_Sup'Access, Expr.O_Inf => F_Inf'Access, Expr.O_Esup => F_Esup'Access, Expr.O_Einf => F_Einf'Access, Expr.O_Equal => F_Equ'Access, Expr.O_Diff => F_Diff'Access); U_Op_Table : constant array (Expr.U_Ops) of U_Ops_Fct := (Expr.O_Not => F_Not'Access); begin case E.Kind is when Expr.Value => return To_String (E.V); when Expr.Var => return Translate (E.Var); when Expr.Op => return Op_Table (E.O) (Analyze (E.Left), Analyze (E.Right)); when Expr.U_Op => return U_Op_Table (E.U_O) (Analyze (E.Next)); end case; end Analyze; ------------- -- Get_Max -- ------------- procedure Get_Max (T : in Tree; Max_Lines : out Natural; Max_Expand : out Natural) is function Get_Max_Lines (T : in Tree; N : in Positive) return Natural; -- Recursivelly descend the tree and compute the max lines that -- will be displayed into the table. function Count_Section return Natural; -- Returns the number of section into table T; ------------------- -- Count_Section -- ------------------- function Count_Section return Natural is C : Natural := 0; S : Tree := T.Sections; begin while S /= null loop C := C + 1; S := S.N_Section; end loop; return C; end Count_Section; ------------------- -- Get_Max_Lines -- ------------------- function Get_Max_Lines (T : in Tree; N : in Positive) return Natural is function Check (T : in Data.Tree) return Natural; -- Returns the length of the largest vector tag found on the -- subtree. ----------- -- Check -- ----------- function Check (T : in Data.Tree) return Natural is use type Data.Tree; use type Data.NKind; Iteration : Natural := Natural'First; D : Data.Tree := T; begin while D /= null loop if D.Kind = Data.Var and then D.Var.Attr = Nil then for K in Translations'Range loop declare Tk : constant Association := Translations (K); begin if D.Var.Name = Tk.Variable then if N = 1 then -- First block level analysed. if Tk.Kind = Vect then -- This is a Vector tag into a top -- level table statement. The number -- of iterations for this table -- statement correspond to the number -- of item into the vector. Iteration := Natural'Max (Iteration, Size (Tk.Vect_Value)); elsif Tk.Kind = Matrix then if State.Table_Level = 0 then -- This is Matrix tag into a top -- level table statement. The -- number of iterations for this -- table statement correspond to -- the number of vector into the -- table. Iteration := Natural'Max (Iteration, Size (Tk.Mat_Value)); else -- This is Matrix tag into an -- embbeded table statement (table -- statement into a table -- statement). The number of -- iterations for this table -- statement correspond to the -- largest number of items in the -- Matrix tag's vectors. Iteration := Tk.Mat_Value.M.Max; end if; end if; elsif N = 2 then -- Second block level analysed. if Tk.Kind = Matrix then -- This is a Matrix tag into an -- embedded table statement (table -- statement into a table statement) -- analysed at the second block -- level. This is to report the number -- of iterations for upper level table -- statement. This number of -- iterations correspond to the -- smallest number of vectors into the -- table. Iteration := Natural'Max (Iteration, Size (Tk.Mat_Value)); end if; end if; end if; end; end loop; end if; D := D.Next; end loop; return Iteration; end Check; begin if T = null then return Natural'First; end if; case T.Kind is when Info | C_Info => return Get_Max_Lines (T.Next, N); when Text => return Natural'Max (Check (T.Text), Get_Max_Lines (T.Next, N)); when If_Stmt => return Natural'Max (Natural'Max (Get_Max_Lines (T.N_True, N), Get_Max_Lines (T.N_False, N)), Get_Max_Lines (T.Next, N)); when Table_Stmt => if N = 1 then return Natural'Max (Get_Max_Lines (T.Sections, N + 1), Get_Max_Lines (T.Next, N)); else return Natural'First; end if; when Section_Stmt => return Natural'Max (Get_Max_Lines (T.Next, N), Get_Max_Lines (T.N_Section, N)); when Include_Stmt => return Natural'Max (Get_Max_Lines (T.File.Info, N), Get_Max_Lines (T.Next, N)); end case; end Get_Max_Lines; Result : Natural := Get_Max_Lines (T.Sections, 1); begin pragma Assert (T.Kind = Table_Stmt); Max_Lines := Result; if T.Terminate_Sections then declare N_Section : constant Positive := Count_Section; begin if Result mod N_Section /= 0 then Result := Result + N_Section - (Result mod N_Section); end if; end; end if; Max_Expand := Result; end Get_Max; ------------- -- Is_True -- ------------- function Is_True (Str : in String) return Boolean is L_Str : constant String := Characters.Handling.To_Upper (Str); begin return L_Str = "TRUE"; end Is_True; begin if T = null then return; end if; case T.Kind is when Info | C_Info => Analyze (T.Next, State); when Text => begin Analyze (T.Text); exception when E : others => Exceptions.Raise_Exception (Template_Error'Identity, "In " & Filename & " at line" & Natural'Image (T.Line) & ", " & Exceptions.Exception_Message (E) & '.'); end; Analyze (T.Next, State); when If_Stmt => if Analyze (T.Cond) = "TRUE" then Analyze (T.N_True, State); else Analyze (T.N_False, State); end if; Analyze (T.Next, State); when Table_Stmt => declare Max_Lines, Max_Expand : Natural; begin Get_Max (T, Max_Lines, Max_Expand); Analyze (T.Sections, Table_State'(State.I, State.J, Max_Lines, Max_Expand, State.Table_Level + 1, State.Section_Number + 1)); end; Analyze (T.Next, State); when Section_Stmt => declare First_Section : Tree := T; Current : Tree := T; Section : Positive := 1; begin for K in 1 .. State.Max_Expand loop Analyze (Current.Next, Table_State'(State.J, K, State.Max_Lines, State.Max_Expand, State.Table_Level, Section)); Current := Current.N_Section; Section := Section + 1; if Current = null then Current := First_Section; Section := 1; end if; end loop; end; when Include_Stmt => Analyze (T.File.Info, State); Analyze (T.Next, State); end case; end Analyze; T : Static_Tree; begin T := Load (Filename, Cached); Now := Ada.Calendar.Clock; -- Used for the time related variable Analyze (T.C_Info, Empty_State); if not Cached then Release (T.Info); else Cached_Files.Prot.Release (T); end if; -- Flush buffer and return result Append (Results, Buffer (1 .. Last)); return Results; end Parse; ------------- -- Release -- ------------- procedure Release (T : in out Tree) is begin if T = null then return; end if; case T.Kind is when Info => declare I : Tree := T.I_File; O : Tree; begin while I /= null loop O := I; I := I.Next; Free (O); end loop; end; Release (T.Next); Free (T); when C_Info => Release (T.Next); Free (T); when Text => Data.Release (T.Text); Release (T.Next); Free (T); when If_Stmt => Expr.Release (T.Cond); Release (T.N_True); Release (T.N_False); Release (T.Next); Free (T); when Table_Stmt => Release (T.Sections); Release (T.Next); Free (T); when Section_Stmt => Release (T.Next); Release (T.N_Section); Free (T); when Include_Stmt => T.File.Info.Ref := T.File.Info.Ref - 1; if T.File.Info.Ref = 0 then -- No more reference to this include file we release it. Release (T.File.Info); end if; Release (T.Next); Free (T); end case; end Release; ------------------------ -- Set_Tag_Separators -- ------------------------ procedure Set_Tag_Separators (Start_With : in String := Default_Begin_Tag; Stop_With : in String := Default_End_Tag) is begin Begin_Tag := To_Unbounded_String (Start_With); End_Tag := To_Unbounded_String (Stop_With); end Set_Tag_Separators; --------------- -- Translate -- --------------- function Translate (Template : in String; Translations : in Translate_Table := No_Translation) return String is T : Data.Tree := Data.Parse (Template); P : Data.Tree := T; Results : Unbounded_String; function Translate (Var : in Tag) return String; -- Returns translation for Var. --------------- -- Translate -- --------------- function Translate (Var : in Tag) return String is begin for K in Translations'Range loop if Var.Name = Translations (K).Variable then declare Tk : constant Association := Translations (K); begin case Tk.Kind is when Std => return Translate (Var, To_String (Tk.Value)); when others => return ""; end case; end; end if; end loop; return ""; end Translate; use type Data.Tree; begin while P /= null loop case P.Kind is when Data.Text => Append (Results, P.Value); when Data.Var => Append (Results, Translate (P.Var)); end case; P := P.Next; end loop; Data.Release (T); return To_String (Results); end Translate; end Templates_Parser;