* Added event-based fetching of variables

git-svn-id: trunk@33947 -

packages/fcl-base/src/fpexprpars.pp

@@ -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;

packages/fcl-base/tests/fclbase-unittests.lpi

@@ -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">

packages/fcl-base/tests/fclbase-unittests.pp

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

packages/fcl-base/tests/testexprpars.pp

@@ -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);