paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-30 12:21:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Added event-based fetching of variables

Browse Source 
git-svn-id: trunk@33947 -
This commit is contained in:
michael 2016-06-11 17:07:32 +00:00
parent c205cb03c8
commit 56d3909dea
4 changed files with 208 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
packages/fcl-base/src/fpexprpars.pp
View File

@ -404,11 +404,15 @@ Type
TIdentifierType = (itVariable,itFunctionCallBack,itFunctionHandler);
TFPExprFunctionCallBack = Procedure (Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
TFPExprFunctionEvent = Procedure (Var Result : TFPExpressionResult; Const Args : TExprParameterArray) of object;
TFPExprVariableCallBack = Procedure (Var Result : TFPExpressionResult; ConstRef AName : ShortString);
TFPExprVariableEvent = Procedure (Var Result : TFPExpressionResult; ConstRef AName : ShortString) of Object;
{ TFPExprIdentifierDef }
TFPExprIdentifierDef = Class(TCollectionItem)
private
FOnGetVarValue: TFPExprVariableEvent;
FOnGetVarValueCB: TFPExprVariableCallBack;
FStringValue : String;
FValue : TFPExpressionResult;
FArgumentTypes: String;
@ -435,15 +439,18 @@ Type
Protected
Procedure CheckResultType(Const AType : TResultType);
Procedure CheckVariable;
Procedure FetchValue;
Public
Function ArgumentCount : Integer;
Procedure Assign(Source : TPersistent); override;
Function EventBasedVariable : Boolean; Inline;
Property AsFloat : TExprFloat Read GetAsFloat Write SetAsFloat;
Property AsInteger : Int64 Read GetAsInteger Write SetAsInteger;
Property AsString : String Read GetAsString Write SetAsString;
Property AsBoolean : Boolean Read GetAsBoolean Write SetAsBoolean;
Property AsDateTime : TDateTime Read GetAsDateTime Write SetAsDateTime;
Property OnGetFunctionValueCallBack : TFPExprFunctionCallBack Read FOnGetValueCB Write FOnGetValueCB;
Property OnGetVariableValueCallBack : TFPExprVariableCallBack Read FOnGetVarValueCB Write FOnGetVarValueCB;
Published
Property IdentifierType : TIdentifierType Read FIDType Write FIDType;
Property Name : ShortString Read FName Write SetName;
@ -451,6 +458,7 @@ Type
Property ParameterTypes : String Read FArgumentTypes Write SetArgumentTypes;
Property ResultType : TResultType Read GetResultType Write SetResultType;
Property OnGetFunctionValue : TFPExprFunctionEvent Read FOnGetValue Write FOnGetValue;
Property OnGetVariableValue : TFPExprVariableEvent Read FOnGetVarValue Write FOnGetVarValue;
end;
@ -482,6 +490,8 @@ Type
Function IndexOfIdentifier(Const AName : ShortString) : Integer;
Function FindIdentifier(Const AName : ShortString) : TFPExprIdentifierDef;
Function IdentifierByName(Const AName : ShortString) : TFPExprIdentifierDef;
Function AddVariable(Const AName : ShortString; AResultType : TResultType; ACallback : TFPExprVariableCallBack) : TFPExprIdentifierDef;
Function AddVariable(Const AName : ShortString; AResultType : TResultType; ACallback : TFPExprVariableEvent) : TFPExprIdentifierDef;
Function AddVariable(Const AName : ShortString; AResultType : TResultType; AValue : String) : TFPExprIdentifierDef;
Function AddBooleanVariable(Const AName : ShortString; AValue : Boolean) : TFPExprIdentifierDef;
Function AddIntegerVariable(Const AName : ShortString; AValue : Integer) : TFPExprIdentifierDef;
@ -1601,7 +1611,29 @@ begin
RaiseParserError(SErrUnknownIdentifier,[AName]);
end;
function TFPExprIdentifierDefs.AddVariable(Const AName: ShortString;
function TFPExprIdentifierDefs.AddVariable(const AName: ShortString;
AResultType: TResultType; ACallback: TFPExprVariableCallBack
): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
Result.Name:=AName;
Result.ResultType:=AResultType;
Result.OnGetVariableValueCallBack:=ACallBack
end;
function TFPExprIdentifierDefs.AddVariable(const AName: ShortString;
AResultType: TResultType; ACallback: TFPExprVariableEvent
): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
Result.Name:=AName;
Result.ResultType:=AResultType;
Result.OnGetVariableValue:=ACallBack
end;
function TFPExprIdentifierDefs.AddVariable(const AName: ShortString;
AResultType: TResultType; AValue: String): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
@ -1611,8 +1643,8 @@ begin
Result.Value:=AValue;
end;
function TFPExprIdentifierDefs.AddBooleanVariable(Const AName: ShortString; AValue: Boolean
): TFPExprIdentifierDef;
function TFPExprIdentifierDefs.AddBooleanVariable(const AName: ShortString;
AValue: Boolean): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
@ -1621,8 +1653,8 @@ begin
Result.FValue.ResBoolean:=AValue;
end;
function TFPExprIdentifierDefs.AddIntegerVariable(Const AName: ShortString; AValue: Integer
): TFPExprIdentifierDef;
function TFPExprIdentifierDefs.AddIntegerVariable(const AName: ShortString;
AValue: Integer): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
@ -1631,8 +1663,8 @@ begin
Result.FValue.ResInteger:=AValue;
end;
function TFPExprIdentifierDefs.AddFloatVariable(Const AName: ShortString; AValue: TExprFloat
): TFPExprIdentifierDef;
function TFPExprIdentifierDefs.AddFloatVariable(const AName: ShortString;
AValue: TExprFloat): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
@ -1641,8 +1673,8 @@ begin
Result.FValue.ResFloat:=AValue;
end;
function TFPExprIdentifierDefs.AddStringVariable(Const AName: ShortString; AValue: String
): TFPExprIdentifierDef;
function TFPExprIdentifierDefs.AddStringVariable(const AName: ShortString;
AValue: String): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
@ -1651,8 +1683,8 @@ begin
Result.FValue.ResString:=AValue;
end;
function TFPExprIdentifierDefs.AddDateTimeVariable(Const AName: ShortString; AValue: TDateTime
): TFPExprIdentifierDef;
function TFPExprIdentifierDefs.AddDateTimeVariable(const AName: ShortString;
AValue: TDateTime): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
@ -1739,6 +1771,8 @@ procedure TFPExprIdentifierDef.CheckVariable;
begin
If Identifiertype<>itvariable then
RaiseParserError(SErrNotVariable,[Name]);
if EventBasedVariable then
FetchValue;
end;
function TFPExprIdentifierDef.ArgumentCount: Integer;
@ -1762,6 +1796,8 @@ begin
FName:=EID.FName;
FOnGetValue:=EID.FOnGetValue;
FOnGetValueCB:=EID.FOnGetValueCB;
FOnGetVarValue:=EID.FOnGetVarValue;
FOnGetVarValueCB:=EID.FOnGetVarValueCB;
end
else
inherited Assign(Source);
@ -1828,6 +1864,35 @@ begin
end;
end;
procedure TFPExprIdentifierDef.FetchValue;
Var
RT,RT2 : TResultType;
begin
RT:=FValue.ResultType;
if Assigned(FOnGetVarValue) then
FOnGetVarValue(FValue,FName)
else
FOnGetVarValueCB(FValue,FName);
RT2:=FValue.ResultType;
if RT2<>RT then
begin
// Restore
FValue.ResultType:=RT;
Raise EExprParser.CreateFmt('Value handler for variable %s returned wrong type, expected "%s", got "%s"',[
FName,
GetEnumName(TypeInfo(TResultType),Ord(rt)),
GetEnumName(TypeInfo(TResultType),Ord(rt2))
]);
end;
end;
function TFPExprIdentifierDef.EventBasedVariable: Boolean;
begin
Result:=Assigned(FOnGetVarValue) or Assigned(FOnGetVarValueCB);
end;
function TFPExprIdentifierDef.GetResultType: TResultType;
begin
Result:=FValue.ResultType;

23
packages/fcl-base/tests/fclbase-unittests.lpi
View File

@ -1,4 +1,4 @@
<?xml version="1.0"?>
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
@ -6,7 +6,6 @@
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
@ -31,35 +30,35 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
<CommandLineParams Value="--suite=TTestParserVariables.TestVariable31"/>
</local>
</RunParams>
<Units Count="2">
<Units Count="3">
<Unit0>
<Filename Value="fclbase-unittests.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fclbase_unittests"/>
</Unit0>
<Unit1>
<Filename Value="tchashlist.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="tchashlist"/>
</Unit1>
<Unit2>
<Filename Value="testexprpars.pp"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="project1"/>
<Filename Value="fclbase-unittests"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../src"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">

2
packages/fcl-base/tests/fclbase-unittests.pp
View File

@ -10,6 +10,8 @@ var
Application: TTestRunner;
begin
DefaultFormat:=fPlain;
DefaultRunAllTests:=True;
Application := TTestRunner.Create(nil);
Application.Initialize;
Application.Title := 'FCL-Base unittests';

120
packages/fcl-base/tests/testexprpars.pp
View File

@ -20,7 +20,7 @@ unit testexprpars;
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry,fpexprpars;
Classes, SysUtils, fpcunit, testutils, testregistry, fpexprpars;
type
@ -701,6 +701,12 @@ type
TTestParserVariables = Class(TTestExpressionParser)
private
FAsWrongType : TResultType;
FEventName: String;
FBoolValue : Boolean;
FTest33 : TFPExprIdentifierDef;
procedure DoGetBooleanVar(var Res: TFPExpressionResult; ConstRef AName: ShortString);
procedure DoGetBooleanVarWrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
procedure DoTestVariable33;
procedure TestAccess(Skip: TResultType);
Protected
procedure AddVariabletwice;
@ -741,6 +747,10 @@ type
procedure TestVariable28;
procedure TestVariable29;
procedure TestVariable30;
procedure TestVariable31;
procedure TestVariable32;
procedure TestVariable33;
procedure TestVariable34;
end;
{ TTestParserFunctions }
@ -4196,6 +4206,114 @@ begin
AssertEquals('Correct value',False,I.AsBoolean);
end;
procedure TTestParserVariables.DoGetBooleanVar(var Res: TFPExpressionResult;
ConstRef AName: ShortString);
begin
FEventName:=AName;
Res.ResBoolean:=FBoolValue;
end;
procedure TTestParserVariables.TestVariable31;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar);
AssertEquals('Correct name','a',i.Name);
AssertEquals('Correct type',Ord(rtBoolean),Ord(i.ResultType));
AssertSame(TMethod(I.OnGetVariableValue).Code,TMethod(@DoGetBooleanVar).Code);
FBoolValue:=True;
FEventName:='';
AssertEquals('Correct value 1',True,I.AsBoolean);
AssertEquals('Correct name passed','a',FEventName);
FBoolValue:=False;
FEventName:='';
AssertEquals('Correct value 2',False,I.AsBoolean);
AssertEquals('Correct name passed','a',FEventName);
end;
Var
FVarCallBackName:String;
FVarBoolValue : Boolean;
procedure DoGetBooleanVar2(var Res: TFPExpressionResult; ConstRef AName: ShortString);
begin
FVarCallBackName:=AName;
Res.ResBoolean:=FVarBoolValue;
end;
procedure TTestParserVariables.DoGetBooleanVarWrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
begin
FEventName:=AName;
Res.ResultType:=rtInteger;
Res.ResInteger:=33;
end;
procedure TTestParserVariables.TestVariable32;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar2);
AssertEquals('Correct name','a',i.Name);
AssertEquals('Correct type',Ord(rtBoolean),Ord(i.ResultType));
AssertSame(I.OnGetVariableValueCallBack,@DoGetBooleanVar2);
FVarBoolValue:=True;
FVarCallBackName:='';
AssertEquals('Correct value 1',True,I.AsBoolean);
AssertEquals('Correct name passed','a',FVarCallBackName);
FVarBoolValue:=False;
FVarCallBackName:='';
AssertEquals('Correct value 2',False,I.AsBoolean);
AssertEquals('Correct name passed','a',FVarCallBackName);
end;
procedure TTestParserVariables.DoTestVariable33;
Var
B : Boolean;
begin
B:=FTest33.AsBoolean;
end;
procedure TTestParserVariables.TestVariable33;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVarWrong);
FTest33:=I;
AssertException('Changing type results in exception',EExprParser,@DoTestVariable33);
AssertEquals('Type is unchanged',Ord(rtBoolean),Ord(i.ResultType));
end;
procedure DoGetBooleanVar2Wrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
begin
FVarCallBackName:=AName;
Res.ResultType:=rtInteger;
Res.ResInteger:=34;
end;
procedure TTestParserVariables.TestVariable34;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar2Wrong);
FTest33:=I;
AssertException('Changing type results in exception',EExprParser,@DoTestVariable33);
AssertEquals('Type is unchanged',Ord(rtBoolean),Ord(i.ResultType));
end;
Procedure EchoDate(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);