diff options
Diffstat (limited to 'packages/fcl-mustache/src/fpexmustache.pp')
| -rw-r--r-- | packages/fcl-mustache/src/fpexmustache.pp | 399 |
1 files changed, 399 insertions, 0 deletions
diff --git a/packages/fcl-mustache/src/fpexmustache.pp b/packages/fcl-mustache/src/fpexmustache.pp new file mode 100644 index 0000000000..6191e6bd78 --- /dev/null +++ b/packages/fcl-mustache/src/fpexmustache.pp @@ -0,0 +1,399 @@ +{ + This file is part of the Free Pascal Run time library. + Copyright (c) 2021 by Michael Van Canneyt (michael@freepascal.org) + + This file contains a Mustache descendent with FPExpr parser expression support + + See the File COPYING.FPC, included in this distribution, + for details about the copyright. + + This program 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. + + **********************************************************************} + +unit fpexmustache; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, fpexprpars, fpmustache, fpjson; + +Type + + { TMustacheExprElement } + + TMustacheExprElement = Class(TMustacheElement) + private + FNode: TFPExprNode; + FExpr : TMustacheString; + Protected + Procedure SetNode(aNode : TFPExprNode); virtual; + Function GetData : TMustacheString;override; + Procedure SetData(const aValue : TMustacheString) ; override; + Public + Destructor Destroy; override; + Procedure Render(aContext : TMustacheContext; aOutput : TMustacheOutput; const aPrefix : String = ''; aLast : Boolean = False); override; + Property Node : TFPExprNode Read FNode; + end; + + { TMustacheExprParser } + + TMustacheExprParser = class(TMustacheParser) + private + FExprEnd: Char; + FExprParser: TFPExpressionParser; + FExprStart: Char; + Protected + function CreateDefault(aParent: TMustacheElement; aPosition: Integer; const aName: String): TMustacheElement; override; + Public + Constructor Create(aTemplate : TMustacheString = '';aStart: TMustacheString='';aStop: TMustacheString = ''); override; + // Default [ + Property ExprStart : Char Read FExprStart Write FExprStart; + // Default ] + Property ExprEnd : Char Read FExprEnd Write FExprEnd; + // Our instance + Property ExprParser : TFPExpressionParser Read FExprParser Write FExprParser; + end; + + { TMustacheExpr } + + TMustacheExpr = Class(TMustache) + private + FExprEndChar: String; + FExpressionParser: TFPExpressionParser; + FExprStartChar: String; + FCurrentContext : TMustacheContext; + function GetResultType(aValue: TJSONData): TResultType; + procedure SetExprEndChar(AValue: String); + procedure SetExpressionParser(AValue: TFPExpressionParser); + procedure SetExprStartChar(AValue: String); + function DoGetExpressionParser : TFPExpressionParser; + Protected + procedure DoGetVariable(var Result: TFPExpressionResult; ConstRef AName: ShortString); virtual; + Procedure Notification(AComponent: TComponent; Operation: TOperation); override; + Function CreateParser(aTemplate: TMustacheString): TMustacheParser; override; + function GetExpressionParser(aOwner : TComponent): TFPExpressionParser; virtual; + Public + Constructor Create(aOwner : TComponent); override; + Procedure Render(aContext : TMustacheContext; aOutput : TMustacheOutput); override; overload; + // Register variables from JSON in the expression engine. + // If UseEvent is true, the variables will be retrieved while parsing with an event. + // If UseEvent is false, the variables will be registered as static values. + Procedure RegisterVariables (aContext : TMustacheJSONContext; aPath : TJSONStringType = ''; UseEvent : Boolean = True); + Procedure RegisterVariables (aJSON : String; aPath : TJSONStringType = ''; UseEvent : Boolean = True); + Procedure RegisterVariables (aJSON : TJSONObject; aPath : TJSONStringType = ''; UseEvent : Boolean = True); + Published + // Default [ + Property ExprStartChar : String Read FExprStartChar Write SetExprStartChar; + // Default ] + Property ExprEndChar : String Read FExprEndChar Write SetExprEndChar; + // An expression parser instance. If none is specified, then a default is created. + Property ExpressionParser : TFPExpressionParser Read DoGetExpressionParser Write SetExpressionParser; + end; + + { TMustacheExpressionParser } + + TMustacheExpressionParser = class(TFPExpressionParser) + end; + +implementation + +uses sysutils; + +Resourcestring + SErrLengthStartMustBe1 = 'Length expression start delimiter must be 1'; + SErrLengthEndMustBe1 = 'Length expression end delimiter must be 1'; + +{ TMustacheExprElement } + +procedure TMustacheExprElement.SetNode(aNode: TFPExprNode); +begin + FNode:=aNode; +end; + +function TMustacheExprElement.GetData: TMustacheString; +begin + Result:=FExpr; +end; + +procedure TMustacheExprElement.SetData(const aValue: TMustacheString); +begin + FExpr:=aValue; +end; + +procedure TMustacheExprElement.Render(aContext: TMustacheContext; + aOutput: TMustacheOutput; const aPrefix: String; aLast: Boolean); + +Var + Res : TFPExpressionResult; + S : TMustacheString; + +begin + Res:=Node.NodeValue; + case Res.ResultType of + rtString : S:=Res.ResString; + rtBoolean : S:=BoolToStr(Res.ResBoolean,True); + rtInteger : S:=IntToStr(Res.ResInteger); + rtFloat : S:=FormatFloat('0.0#######',Res.ResFloat); + rtCurrency : S:=CurrToStr(Res.ResCurrency); + rtDateTime : S:=DateTimeToStr(Res.ResDateTime); + end; + aOutput.Output(aPrefix+S); +end; + +destructor TMustacheExprElement.Destroy; +begin + FreeAndNil(FNode); + inherited Destroy; +end; + +{ TMustacheExprParser } + +function TMustacheExprParser.CreateDefault(aParent: TMustacheElement; + aPosition: Integer; const aName: String): TMustacheElement; + +Var + L : Integer; + N : TFPExprNode; + +begin + N:=Nil; + L:=Length(aName); + If (aName[1]=FExprStart) and (aName[L]=FExprEnd) then + begin + Result:=TMustacheExprElement.Create(metVariable,aParent,aPosition); + Result.Data:=Copy(aName,2,L-2); + ExprParser.Expression:=Result.Data; + ExprParser.ExtractNode(N); + TMustacheExprElement(Result).SetNode(N); + aParent.AddChild(Result); + end + else + Result:=Inherited CreateDefault(aParent,aPosition,aName); +end; + +constructor TMustacheExprParser.Create(aTemplate: TMustacheString; + aStart: TMustacheString; aStop: TMustacheString); +begin + inherited Create(aTemplate, aStart, aStop); + FExprStart:='['; + FExprEnd:=']'; +end; + +{ TMustacheExpr } + +procedure TMustacheExpr.SetExprEndChar(AValue: String); +begin + if FExprEndChar=AValue then Exit; + if Length(aValue)<>1 then + EMustache.Create(SErrLengthStartMustBe1); + FExprEndChar:=AValue; +end; + +function TMustacheExpr.GetExpressionParser(aOwner : TComponent): TFPExpressionParser; +begin + Result:=TMustacheExpressionParser.Create(AOwner); +end; + +procedure TMustacheExpr.SetExpressionParser(AValue: TFPExpressionParser); + +begin + if FExpressionParser=AValue then Exit; + If assigned(FExpressionParser) then + FExpressionParser.RemoveFreeNotification(Self); + FExpressionParser:=AValue; + If assigned(FExpressionParser) then + FExpressionParser.FreeNotification(Self); +end; + +procedure TMustacheExpr.SetExprStartChar(AValue: String); +begin + if FExprStartChar=AValue then Exit; + if Length(aValue)<>1 then + EMustache.Create(SErrLengthEndMustBe1); + FExprStartChar:=AValue; +end; + +function TMustacheExpr.DoGetExpressionParser: TFPExpressionParser; +begin + if FExpressionParser=Nil then + begin + FExpressionParser:=GetExpressionParser(Self); + FExpressionParser.SetSubComponent(True); + FExpressionParser.FreeNotification(Self); + end; + Result:=FExpressionParser; +end; + +procedure TMustacheExpr.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation=opRemove) and (aComponent=FExpressionParser) then + FExpressionParser:=Nil; +end; + +function TMustacheExpr.CreateParser(aTemplate: TMustacheString ): TMustacheParser; + +Var + Exp : TMustacheExprParser; + +begin + Exp:=TMustacheExprParser.Create(aTemplate); + Exp.ExprParser:=Self.ExpressionParser; + Result:=Exp; +end; + +constructor TMustacheExpr.Create(aOwner: TComponent); +begin + inherited Create(aOwner); + DoGetExpressionParser; +end; + +procedure TMustacheExpr.Render(aContext: TMustacheContext; aOutput: TMustacheOutput); + +begin + FCurrentContext:=aContext; + try + inherited Render(aContext, aOutput); + finally + FCurrentContext:=nil; + end; +end; + +procedure TMustacheExpr.DoGetVariable(var Result: TFPExpressionResult; ConstRef + AName: ShortString); + +Var + S : TMustacheString; + V : Double; + C : Integer; + +begin + If not Assigned(FCurrentContext) then + case result.ResultType of + rtInteger : Result.ResInteger:=0; + rtDateTime : Result.ResDateTime:=0.0; + rtString : Result.ResString:=''; + rtFloat: Result.ResFloat:=0.0; + rtCurrency: Result.ResCurrency:=0.0; + rtBoolean: Result.ResBoolean:=False; + end + else + begin + S:=FCurrentContext.GetTextValue(aName); + case result.ResultType of + rtInteger : Result.ResInteger:=StrToInt64Def(S,0); + rtDateTime : if Not TryStrToDateTime(S,Result.ResDateTime) then + Result.ResDateTime:=0.0; + rtString : Result.ResString:=S; + rtFloat: begin + Val(S,V,C); + if C<>0 then + Result.ResFloat:=0.0 + else + Result.ResFloat:=V; + end; + rtCurrency: + begin + Val(S,V,C); + if (C<>0) then + Result.ResCurrency:=0.0 + else + Result.ResCurrency:=V; + end; + rtBoolean: Result.ResBoolean:=StrToBoolDef(S,False); + end; + end; +end; + +function TMustacheExpr.GetResultType(aValue: TJSONData): TResultType; + +begin + Case aValue.JSONType of + jtBoolean : Result:=rtBoolean; + jtString, + jtArray, + jtObject, + jtNull : Result:=rtString; + jtNumber : + begin + Case TJSONNumber(aValue).NumberType of + ntFloat : Result:=rtFloat; + ntInteger, + ntInt64 : Result:=rtInteger; + ntQWord : Raise EMustache.Create('Unsupported JSON type'); + end; + end; + end; +end; + +procedure TMustacheExpr.RegisterVariables(aContext: TMustacheJSONContext; + aPath: TJSONStringType; UseEvent: Boolean); + +begin + RegisterVariables(aContext.RootData as TJSONObject,aPath,UseEvent); +end; + +procedure TMustacheExpr.RegisterVariables(aJSON: String; + aPath: TJSONStringType; UseEvent: Boolean); + +Var + aData : TJSONData; + aObj : TJSONObject absolute aData; + + +begin + aData:=getJSON(aJSON,True); + try + if aData is TJSONObject then + RegisterVariables(aObj,aPath,useEvent) + else + Raise EMustache.Create('Invalid JSON data to register variables'); + finally + aData.Free; + end; +end; + +procedure TMustacheExpr.RegisterVariables(aJSON: TJSONObject; aPath: TJSONStringType; UseEvent: Boolean); + +Var + aData,aValue : TJSONData; + aEnum : TJSONEnum; + aKey : TJSONStringType; + rt : TResultType; + aParser : TFPExpressionParser; + +begin + aParser:=ExpressionParser; + aData:=aJSON.FindPath(aPath); + if aData is TJSONObject then + for aEnum in aData do + begin + aKey:=aEnum.Key; + aValue:=aEnum.Value; + rt:=GetResultType(aValue); + if UseEvent then + aParser.Identifiers.AddVariable(aKey,rt,@DoGetVariable) + else + case rt of + rtBoolean: aParser.Identifiers.AddBooleanVariable(aKey,aValue.AsBoolean); + rtFloat: aParser.Identifiers.AddFloatVariable(aKey,aValue.AsFloat); + rtInteger: aParser.Identifiers.AddIntegerVariable(aKey,aValue.AsInteger); + rtString: Case aValue.JSONType of + jtNull: aParser.Identifiers.AddStringVariable(aKey,''); + jtArray, + jtObject: aParser.Identifiers.AddStringVariable(aKey, aValue.AsJSON); + else + aParser.Identifiers.AddStringVariable(aKey,aValue.AsString); + end; + end; + end; +end; + +end. + |