paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-27 17:07:30 +01:00
Code Issues Packages Projects Releases Wiki Activity

FpDebug: tests

Browse Source 
git-svn-id: trunk@61901 -
This commit is contained in:
martin 2019-09-18 22:14:04 +00:00
parent e2590a7c19
commit 0ea8345dd4
4 changed files with 254 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
components/lazdebuggers/lazdebuggerfp/test/testwatches.pas
View File

@ -1518,6 +1518,7 @@ procedure TTestWatches.TestWatchesTypeCast;
var var
p, e, val: String; p, e, val: String;
Thread, n, StartIdx, i: Integer; Thread, n, StartIdx, i: Integer;
we: PWatchExpectation;
begin begin
p := APrefix; p := APrefix;
n := AOffs; n := AOffs;
@ -1606,6 +1607,46 @@ for i := StartIdx to t.Count-1 do
t.Tests[i].SkipIf(ALoc = tlConst); t.Tests[i].SkipIf(ALoc = tlConst);
if p='gv' then begin
we:= t.Add(AName, '^TRecordClass1(gv_aptr_Class1Rec[0])^.Foo', weClass([weInteger(22+n).N('FInt'), weAnsiStr(AChr1+'T').N('FAnsi')], 'TClass1') )
.AddFlag(ehMissingFields);
we^.EvalCallTestFlags := [defFullTypeInfo];
we:= t.Add(AName, '^TRecordClass1(gv_aptr_Class1Rec[1])^.Foo', weClass([weInteger(22+n+2).N('FInt'), weAnsiStr('D'+'T').N('FAnsi')], 'TClass1') )
.AddFlag(ehMissingFields);
we^.EvalCallTestFlags := [defFullTypeInfo];
we:= t.Add(AName, '^TRecordFive(gv_ptr_FiveRec)^.a', weInteger(-22-n));
we^.EvalCallTestFlags := [defFullTypeInfo];
t.Add(AName, '^TRecordFive(gv_aptr_FiveRec[0])^.a', weInteger(-22-n));
t.Add(AName, '^TRecordFive(gv_aptr_FiveRec[1])^.a', weInteger(-22-(n+2)));
t.Add(AName, 'PTxFiveRec(gv_aptr_FiveRec[0])^.a', weInteger(-22-n));
t.Add(AName, 'PTxFiveRec(gv_aptr_FiveRec[1])^.a', weInteger(-22-(n+2)));
we:= t.Add(AName, '^TRecordFive(gv_ptrlist_FiveRec^[0])^.a', weInteger(-22-n));
we^.TstWatch.EvaluateFlags := [defFullTypeInfo];
we^.EvalCallTestFlags := [defFullTypeInfo];
we:= t.Add(AName, '^TRecordFive(gv_ptrlist_FiveRec^[1])^.a', weInteger(-22-(n+2)));
we^.TstWatch.EvaluateFlags := [defFullTypeInfo];
we^.EvalCallTestFlags := [defFullTypeInfo];
we:= t.Add(AName, 'PTxFiveRec(gv_ptrlist_FiveRec^[0])^.a', weInteger(-22-n));
we^.TstWatch.EvaluateFlags := [defFullTypeInfo];
we^.EvalCallTestFlags := [defFullTypeInfo];
we:= t.Add(AName, 'PTxFiveRec(gv_ptrlist_FiveRec^[1])^.a', weInteger(-22-(n+2)));
we^.TstWatch.EvaluateFlags := [defFullTypeInfo];
we^.EvalCallTestFlags := [defFullTypeInfo];
t.Add(AName, 'PTxFiveRec('+val+')^.a', weInteger(-22-n));
t.Add(AName, '^TRecordFive('+val+')^.a', weInteger(-22-n));
end;
t.Add(AName+' Cardinal', 'Cardinal('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError(); t.Add(AName+' Cardinal', 'Cardinal('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError();
t.Add(AName+' QWord', 'QWord('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError(); t.Add(AName+' QWord', 'QWord('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError();
@ -1648,6 +1689,11 @@ begin
(* ************ Nested Functions ************* *) (* ************ Nested Functions ************* *)
RunToPause(BrkPrg); RunToPause(BrkPrg);
//t.Clear;
//t.Add('', '^TRecordClass1(gv_aptr_Class1Rec[0])^.Foo', weClass([weInteger(22+1).N('FInt'), weAnsiStr('T').N('FAnsi')], 'TClass1') ).AddFlag(ehMissingFields)
//^.EvalCallTestFlags := [defFullTypeInfo];
//t.EvaluateWatches;
//t.CheckResults;
t.Clear; t.Clear;
AddWatchesConv(t, 'glob const', 'gc', 000, 'A', tlConst); AddWatchesConv(t, 'glob const', 'gc', 000, 'A', tlConst);

57
components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas
View File

@ -16,6 +16,9 @@ begin result := SomeValue = 0; end;
procedure SomeProc1(); procedure SomeProc1();
begin SomeFunc1(2,2,2,2); end; begin SomeFunc1(2,2,2,2); end;
const
MaxListSize = high(longword) div 16;
type type
{$ifdef CPU64} {$ifdef CPU64}
PtrUInt = type QWord; PtrUInt = type QWord;
@ -25,12 +28,17 @@ type
PtrUInt = type DWord; PtrUInt = type DWord;
{$endif CPU32} {$endif CPU32}
PPointerList = ^TPointerList;
TPointerList = array[0..MaxListSize - 1] of Pointer;
var var
BreakDummy: PtrUInt; BreakDummy: PtrUInt;
p: Pointer; p: Pointer;
InterfacedObject, InterfacedObject2: TInterfacedObject; InterfacedObject, InterfacedObject2: TInterfacedObject;
type type
TClass1 = class;
TIntRange = -300..300; TIntRange = -300..300;
TCardinalRange = 1..300; TCardinalRange = 1..300;
@ -106,6 +114,8 @@ type
TRecFivePackStatArray = array [2..4] of TRecordFivePack; TRecFivePackStatArray = array [2..4] of TRecordFivePack;
TRecFivePackStatPackArray = packed array [2..4] of TRecordFivePack; TRecFivePackStatPackArray = packed array [2..4] of TRecordFivePack;
TRecordClass1 = record Foo: TClass1; end;
TClass1 = class TClass1 = class
public public
FInt: integer; FInt: integer;
@ -131,22 +141,28 @@ type
type type
(* LOCATION: TYPE *) (* LOCATION: TYPE *)
// type TxByte: type Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=Tx, "_OP_== type ", (=;//, "_O2_= = type", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestType ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=Tx, "_OP_== type ", (=;//, "_O2_= = type", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestType )
// type PTxByte: ^TxByte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=PTx, _OP_={, _O2_={, _pre3_=^Tx, "//@@=} = ", _BLOCK_=TestVar, _BLOCK2_=TestType ) //} TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=PTx, _OP_={, _O2_={, _pre3_=^Tx, "//@@=} = ", _BLOCK_=TestVar, _BLOCK2_=TestType ) //}
// type PxByte: ^Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=Px, "_OP_==^", "_O2_==^", "(=;//", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) //} TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=Px, "_OP_==^", "_O2_==^", "(=;//", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) //}
(* LOCATION: field in baseclass *) (* LOCATION: field in baseclass *)
TMyBaseClass = class TMyBaseClass = class
public public
function SomeMeth1(SomeValue: Integer): Boolean; function SomeMeth1(SomeValue: Integer): Boolean;
public public
// mbcByte: Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mbc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mbc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
end; end;
(* LOCATION: field in class *) (* LOCATION: field in class *)
TMyClass = class(TMyBaseClass) TMyClass = class(TMyBaseClass)
public public
// mcByte: Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
end; end;
@ -154,29 +170,51 @@ var
MyClass1: TMyClass; MyClass1: TMyClass;
MyClass2: TMyBaseClass; (* LOCATION: field, requires typecast of containing class *) MyClass2: TMyBaseClass; (* LOCATION: field, requires typecast of containing class *)
const const
(* LOCATION: global const *) (* LOCATION: global const *)
// gcByte = Byte( 1 + add );
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gc, ADD=0, CHR1='A', _OP_==, _O2_=:, _EQ_==,"(nil)=nil", _BLOCK_=TestConst) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gc, ADD=0, CHR1='A', _OP_==, _O2_=:, _EQ_==,"(nil)=nil", _BLOCK_=TestConst)
var var
(* LOCATION: global var *) (* LOCATION: global var *)
// gvByte: Byte = (1 + add);
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
// gv2_Byte: Byte = (1 + add);
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv2_, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
(* LOCATION: global var ARRAY OF <each type> *) (* LOCATION: global var ARRAY OF <each type> *)
// gvaByte: array of Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gva, "_OP_=: array of", (=;//, "_O2_=: array of", _EQ_=, _BLOCK_=TestVar ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gva, "_OP_=: array of", (=;//, "_O2_=: array of", _EQ_=, _BLOCK_=TestVar )
(* LOCATION: global var pointer <each type> *) (* LOCATION: global var pointer <each type> *)
// gvp_Byte: ^Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvp_, "_OP_=: ^", (=;//, "_O2_=: ^", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvp_, "_OP_=: ^", (=;//, "_O2_=: ^", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer )
(* LOCATION: global var TYPE alias // NO PRE-ASSIGNED VALUE *) (* LOCATION: global var TYPE alias // NO PRE-ASSIGNED VALUE *)
// gvp_Byte: PxByte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvpt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=Px, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) // } TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvpt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=Px, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) // }
(* LOCATION: global var NAMED pointer <each type> // NO PRE-ASSIGNED VALUE *) (* LOCATION: global var NAMED pointer <each type> // NO PRE-ASSIGNED VALUE *)
// gvtt_Byte: TxByte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvtt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=Tx, _BLOCK_=TestVar, _BLOCK2_=TestType ) // } TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvtt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=Tx, _BLOCK_=TestVar, _BLOCK2_=TestType ) // }
(* LOCATION: global var NAMED pointer <each TYPE ALIAS> // NO PRE-ASSIGNED VALUE *) (* LOCATION: global var NAMED pointer <each TYPE ALIAS> // NO PRE-ASSIGNED VALUE *)
// gvptt_Byte: PTxByte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvptt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=PTx, _BLOCK_=TestVar, _BLOCK2_=TestType ) // } TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvptt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=PTx, _BLOCK_=TestVar, _BLOCK2_=TestType ) // }
(* LOCATION: global var untyped pointer // NO PRE-ASSIGNED VALUE *)
// gv_ptr_Byte: pointer;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_ptr_, "_OP_=:pointer;//", "_O2_=:pointer;//" )
// gv_aptr_Byte: array [0..2] of pointer;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_aptr_, "_OP_=:array [0..2] of pointer;//", "_O2_=:array [0..2] of pointer;//" )
(* LOCATION: global var untyped PPointerList // NO PRE-ASSIGNED VALUE *)
// gv_ptrlist_Byte: pointer;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_ptrlist_, "_OP_=:PPointerList;//", "_O2_=:PPointerList;//" )
constructor TObjectCreate3Int64.Create; constructor TObjectCreate3Int64.Create;
begin end; begin end;
destructor TObjectCreate3Int64.Destroy; destructor TObjectCreate3Int64.Destroy;
@ -267,16 +305,31 @@ begin
(* INIT: global var *) (* INIT: global var *)
TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gv, ADD=1, CHR1='B', _OP_=:=, _O2_={, _EQ_=}:=, _pre2_=gc, _BLOCK_=TestAssign) TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gv, ADD=1, CHR1='B', _OP_=:=, _O2_={, _EQ_=}:=, _pre2_=gc, _BLOCK_=TestAssign)
TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gv2_, ADD=3, CHR1='D', _OP_=:=, _O2_={, _EQ_=}:=, _pre2_=gc, _BLOCK_=TestAssign)
(* INIT: global var TYPE alias // NO PRE-ASSIGNED VALUE *) (* INIT: global var TYPE alias // NO PRE-ASSIGNED VALUE *)
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvpt_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) // } TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gvtt_, ADD=7, CHR1='N', _OP_=:=, _O2_={, _EQ_=}:=, _pre2_=gc, _BLOCK_=TestAssign, _BLOCK2_=TestType)
(* INIT: global var NAMED pointer <each type> // NO PRE-ASSIGNED VALUE *) (* INIT: global var NAMED pointer <each type> // NO PRE-ASSIGNED VALUE *)
TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gvtt_, ADD=7, CHR1='N', _OP_=:=, _O2_={, _EQ_=}:=, _pre2_=gc, _BLOCK_=TestAssign, _BLOCK2_=TestType) TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvpt_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) // }
(* INIT: global var NAMED pointer <each TYPE ALIAS> // NO PRE-ASSIGNED VALUE *) (* INIT: global var NAMED pointer <each TYPE ALIAS> // NO PRE-ASSIGNED VALUE *)
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvptt_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gvtt_, _BLOCK_=TestVar, _BLOCK2_=TestType ) // } TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvptt_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gvtt_, _BLOCK_=TestVar, _BLOCK2_=TestType ) // }
(* INIT: global var untyped NAMED pointer // NO PRE-ASSIGNED VALUE *)
// gv_ptr_Byte := @gvByte; // ADD=1, CHR1='B'
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_ptr_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv ) // }
// gv_aptr_Byte[0] := @gvByte; // ADD=1, CHR1='B'
// gv_aptr_Byte[1] := @gv2_Byte; // ADD=3, CHR1='D'
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_aptr_, "{e}=[0]", "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv ) // }
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_aptr_, "{e}=[1]", "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv2_ ) // }
(* INIT: global var untyped PPointerList // NO PRE-ASSIGNED VALUE *)
// gv_ptrlist_Byte := @gv_aptr_Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gv_ptrlist_, "_OP_= {", "_O2_={ ", "//@@=} :=", _pre3_=@gv_aptr_ ) // }
(* INIT: field in class / baseclass *) (* INIT: field in class / baseclass *)
MyClass1 := TMyClass.Create; MyClass1 := TMyClass.Create;
MyClass1.SomeMeth1(1); MyClass1.SomeMeth1(1);

9
components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc
View File

@ -383,7 +383,6 @@
pre__Obj3{e} _O2_ TObject3Int64 _EQ_ (a:-22;b:44;c:4000+ADD); //@@ _pre3_Obj3; pre__Obj3{e} _O2_ TObject3Int64 _EQ_ (a:-22;b:44;c:4000+ADD); //@@ _pre3_Obj3;
pre__Obj3Ex{e} _O2_ TObject3Int64Ex _EQ_ (a:-22;b:44;c:4100+ADD; d: 555); //@@ _pre3_Obj3Ex; pre__Obj3Ex{e} _O2_ TObject3Int64Ex _EQ_ (a:-22;b:44;c:4100+ADD; d: 555); //@@ _pre3_Obj3Ex;
{$IFnDEF TestConst} {$IFnDEF TestConst}
{$IFnDEF TestAssignGC} {$IFnDEF TestAssignGC}
{$IFnDEF TestType} // will work in fpc 3.2.0 upwards {$IFnDEF TestType} // will work in fpc 3.2.0 upwards
@ -443,6 +442,14 @@
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
{$ENDIF} {$ENDIF}
{$IFnDEF TestType}
{$IFnDEF TestAssign}
pre__Class1Rec{e} _O2_ TRecordClass1 _EQ_ (Foo: nil); //@@ _pre3_Class1Rec;
{$ELSE}
pre__Class1Rec{e}.Foo := pre__Instance1{e}; //@@ _pre3_Class1Rec; // }}}
{$ENDIF}
{$ENDIF}
pre__SomeFunc1Ref{e} _O2_ TFunc1 _EQ_ (nil); //@@ _pre3_SomeFunc1Ref; pre__SomeFunc1Ref{e} _O2_ TFunc1 _EQ_ (nil); //@@ _pre3_SomeFunc1Ref;
pre__SomeProc1Ref{e} _O2_ TProc1 _EQ_ (nil); //@@ _pre3_SomeProc1Ref; pre__SomeProc1Ref{e} _O2_ TProc1 _EQ_ (nil); //@@ _pre3_SomeProc1Ref;

250
components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas
View File

@ -130,6 +130,12 @@ type
TstTestName: String; TstTestName: String;
TstWatch: TTestWatch; TstWatch: TTestWatch;
EvalCallTestFlags: TDBGEvaluateFlags;
EvalCallResReceived: Boolean;
EvalCallResSuccess: Boolean;
EvalCallResText: String;
EvalCallResDBGType: TDBGType;
//TstDspFormat: TWatchDisplayFormat; //TstDspFormat: TWatchDisplayFormat;
//TstRepeatCount: Integer; //TstRepeatCount: Integer;
//TstEvaluateFlags: TDBGEvaluateFlags; //TstEvaluateFlags: TDBGEvaluateFlags;
@ -192,6 +198,10 @@ type
FTest: TDBGTestCase; FTest: TDBGTestCase;
FList: array of TWatchExpectation; FList: array of TWatchExpectation;
FTypeNameAliases: TStringList; FTypeNameAliases: TStringList;
FCurEvalCallWatchExp: PWatchExpectation;
procedure EvalCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
function GetCompiler: TTestDbgCompiler; function GetCompiler: TTestDbgCompiler;
function GetDebugger: TTestDbgDebugger; function GetDebugger: TTestDbgDebugger;
function GetLazDebugger: TDebuggerIntf; function GetLazDebugger: TDebuggerIntf;
@ -199,7 +209,7 @@ type
function ParseCommaList(AVal: String; out AFoundCount: Integer; function ParseCommaList(AVal: String; out AFoundCount: Integer;
AMaxLen: Integer = -1; AComma: char = ','): TStringArray; AMaxLen: Integer = -1; AComma: char = ','): TStringArray;
protected protected
function EvaluateWatch(AWatchExp: TWatchExpectation; AThreadId: Integer): Boolean; virtual; function EvaluateWatch(AWatchExp: PWatchExpectation; AThreadId: Integer): Boolean; virtual;
procedure WaitWhileEval; virtual; procedure WaitWhileEval; virtual;
function TestMatches(Name: string; Expected, Got: string; AContext: TWatchExpTestCurrentData; AIgnoreReason: String): Boolean; function TestMatches(Name: string; Expected, Got: string; AContext: TWatchExpTestCurrentData; AIgnoreReason: String): Boolean;
@ -228,6 +238,7 @@ type
function CheckResultPointer(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultPointer(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultPointerAddr(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultPointerAddr(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultArray(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultArray(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckStructureFields(const AnIgnoreRsn: String; var AContext: TWatchExpTestCurrentData): Boolean; virtual;
function CheckResultRecord(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultRecord(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultClass(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultClass(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultObject(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultObject(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
@ -1071,25 +1082,57 @@ begin
end; end;
end; end;
function TWatchExpectationList.EvaluateWatch(AWatchExp: TWatchExpectation; procedure TWatchExpectationList.EvalCallback(Sender: TObject;
ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
begin
if FCurEvalCallWatchExp = nil then begin
DebugLn('???????? Late result');
exit;
end;
FCurEvalCallWatchExp^.EvalCallResSuccess := ASuccess;
FCurEvalCallWatchExp^.EvalCallResText := ResultText;
FCurEvalCallWatchExp^.EvalCallResDBGType := ResultDBGType;
FCurEvalCallWatchExp^.EvalCallResReceived := True;
end;
function TWatchExpectationList.EvaluateWatch(AWatchExp: PWatchExpectation;
AThreadId: Integer): Boolean; AThreadId: Integer): Boolean;
var var
i: Integer; i: Integer;
begin begin
with LazDebugger.GetLocation do with LazDebugger.GetLocation do
FTest.LogText('###### ' + AWatchExp.TstTestName + ' // ' + AWatchExp.TstWatch.Expression + FTest.LogText('###### ' + AWatchExp^.TstTestName + ' // ' + AWatchExp^.TstWatch.Expression +
' (AT '+ SrcFile + ':' + IntToStr(SrcLine) +')' + ' (AT '+ SrcFile + ':' + IntToStr(SrcLine) +')' +
'###### '+LineEnding); '###### '+LineEnding);
AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Value; AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Value;
for i := 1 to 5 do begin for i := 1 to 5 do begin
Application.Idle(False); Application.Idle(False);
Result := AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Validity <> ddsRequested; Result := AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Validity <> ddsRequested;
if Result then break; if Result then break;
WaitWhileEval; WaitWhileEval;
end; end;
FTest.LogText('<<<<< ' + dbgs(AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Validity) + ': ' + FTest.LogText('<<<<< ' + dbgs(AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Validity) + ': ' +
AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Value ); AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Value );
if AWatchExp^.EvalCallTestFlags <> [] then begin
// TODO: set thread/stack
FCurEvalCallWatchExp := AWatchExp;
AWatchExp^.EvalCallResReceived := False;
LazDebugger.Evaluate(AWatchExp^.TstWatch.Expression, @EvalCallback, AWatchExp^.EvalCallTestFlags);
for i := 1 to 5 do begin
Application.Idle(False);
if AWatchExp^.EvalCallResReceived then break;
WaitWhileEval;
end;
FTest.LogText('<<<<< CB:'+ dbgs(AWatchExp^.EvalCallResReceived)+ ' Res'+ dbgs(AWatchExp^.EvalCallResSuccess)+
' Tp:'+dbgs(AWatchExp^.EvalCallResDBGType <> nil)+ ' '+ AWatchExp^.EvalCallResText );
end;
FCurEvalCallWatchExp := nil;
end; end;
procedure TWatchExpectationList.WaitWhileEval; procedure TWatchExpectationList.WaitWhileEval;
@ -1201,6 +1244,12 @@ begin
then then
Context.HasTypeInfo := True; Context.HasTypeInfo := True;
if EvalCallTestFlags <> [] then begin
TestTrue('Got eval res', EvalCallResReceived, Context, AnIgnoreRsn);
TestTrue('Got eval success', EvalCallResSuccess, Context, AnIgnoreRsn);
TestTrue('Got eval type', EvalCallResDBGType <> nil, Context, AnIgnoreRsn);
end;
VerifySymType(Context, AnIgnoreRsn); VerifySymType(Context, AnIgnoreRsn);
VerifyTypeName(Context, AnIgnoreRsn); VerifyTypeName(Context, AnIgnoreRsn);
@ -1308,7 +1357,7 @@ begin
Result := True; Result := True;
Expect := AContext.Expectation; Expect := AContext.Expectation;
if (Expect.ExpTypeName = '') or (not AContext.HasTypeInfo) then if (Expect.ExpTypeName = '') or (Expect.ExpTypeName = #1) or (not AContext.HasTypeInfo) then
exit; exit;
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType]; ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
@ -1703,14 +1752,86 @@ debugln([' expect ',Expect.ExpFullArrayLen,' got "',v,'"' ]);
end; end;
function TWatchExpectationList.CheckStructureFields(const AnIgnoreRsn: String;
var AContext: TWatchExpTestCurrentData): Boolean;
var
Expect: TWatchExpectationResult;
ehf: TWatchExpErrorHandlingFlags;
i, j, e, a: Integer;
parsed: TStringArray;
SubContext: TWatchExpTestCurrentData;
sr: TWatchExpectationResult;
n, v: String;
begin
Result := True;
with AContext.WatchExp do begin
Expect := AContext.Expectation;
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
v := Trim(AContext.WatchVal.Value);
delete(v, 1, pos('(', v));
delete(v, length(v), 1);
parsed := ParseCommaList(v, e, -1, ';');
TestTrue('FieldParser len', e <= Length(parsed), AContext, AnIgnoreRsn);
e := min(e, Length(parsed));
n := FTest.TestBaseName;
SubContext := AContext;
for i := 0 to length(Expect.ExpSubResults) - 1 do begin
sr := Expect.ExpSubResults[i];
if not TestTrue('field name ' + IntToStr(i), sr.ExpFieldName<>'', AContext, AnIgnoreRsn) then
Continue;
if AContext.WatchVal.TypeInfo <> nil then begin
a := AContext.WatchVal.TypeInfo.Fields.Count -1;
while (a >= 0) and (LowerCase(AContext.WatchVal.TypeInfo.Fields[a].Name) <> LowerCase(sr.ExpFieldName)) do
dec(a);
TestTrue('typeinfo has field '+sr.ExpFieldName, a >= 0, AContext, AnIgnoreRsn);
end;
if EvalCallResDBGType <> nil then begin
a := EvalCallResDBGType.Fields.Count -1;
while (a >= 0) and (LowerCase(EvalCallResDBGType.Fields[a].Name) <> LowerCase(sr.ExpFieldName)) do
dec(a);
TestTrue('EvalCallResDBGType has field '+sr.ExpFieldName, a >= 0, AContext, AnIgnoreRsn);
end;
j := parsed.IndexOfFieldName(sr.ExpFieldName, e);
if not TestTrue('field exists ' + IntToStr(i), j >= 0, AContext, AnIgnoreRsn) then
Continue;
if not(ehNoFieldOrder in ehf) then begin
if ehMissingFields in ehf then begin
dec(e, j);
parsed.delete(0, j);
j := 0;
end;
if not TestTrue('field in order ' + IntToStr(i) + ' ' + IntToStr(j), j = 0, AContext, AnIgnoreRsn) then
Continue;
end;
SubContext.WatchVal.Value := parsed.ValueOfFieldName(j);
FTest.TestBaseName := n + ' Idx=' + IntToStr(i);
dec(e);
parsed.delete(j, 1);
//SubContext.WatchExp.TstExpected := sr;
SubContext.Expectation := sr;
Result := CheckData(SubContext, AnIgnoreRsn);
end;
FTest.TestBaseName := n;
AContext.WatchVal.Value := v;
end;
end;
function TWatchExpectationList.CheckResultRecord( function TWatchExpectationList.CheckResultRecord(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var var
Expect, sr: TWatchExpectationResult; Expect: TWatchExpectationResult;
SubContext: TWatchExpTestCurrentData; v, tn: String;
v, n, tn: String;
parsed: TStringArray;
i, e, j: Integer;
ehf: TWatchExpErrorHandlingFlags; ehf: TWatchExpErrorHandlingFlags;
begin begin
with AContext.WatchExp do begin with AContext.WatchExp do begin
@ -1733,60 +1854,16 @@ debugln([' expect ',Expect.ExpFullArrayLen,' got "',v,'"' ]);
if not TestMatches('Is record', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then if not TestMatches('Is record', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then
exit; exit;
delete(v, 1, pos('(', v)); Result := CheckStructureFields(AnIgnoreRsn, AContext);
delete(v, length(v), 1);
parsed := ParseCommaList(v, e, -1, ';');
TestTrue('FieldParser len', e <= Length(parsed), AContext, AnIgnoreRsn);
e := min(e, Length(parsed));
n := FTest.TestBaseName;
SubContext := AContext;
for i := 0 to length(Expect.ExpSubResults) - 1 do begin
sr := Expect.ExpSubResults[i];
if not TestTrue('field name '+IntToStr(i), sr.ExpFieldName<>'', AContext, AnIgnoreRsn) then
Continue;
j := parsed.IndexOfFieldName(sr.ExpFieldName, e);
if not TestTrue('field exists '+IntToStr(i), j >= 0, AContext, AnIgnoreRsn) then
Continue;
if not(ehNoFieldOrder in ehf) then begin
if ehMissingFields in ehf then begin
dec(e, j);
parsed.delete(0, j);
j := 0;
end;
if not TestTrue('field in order '+IntToStr(i), j = 0, AContext, AnIgnoreRsn) then
Continue;
end;
SubContext.WatchVal.Value := parsed.ValueOfFieldName(j);
FTest.TestBaseName := n + ' Idx='+IntToStr(i);
dec(e);
parsed.delete(j, 1);
//SubContext.WatchExp.TstExpected := sr;
SubContext.Expectation := sr;
Result := CheckData(SubContext, AnIgnoreRsn);
end;
FTest.TestBaseName := n;
AContext.WatchVal.Value := v;
end; end;
end; end;
function TWatchExpectationList.CheckResultClass( function TWatchExpectationList.CheckResultClass(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var var
Expect, sr: TWatchExpectationResult; v, tn: String;
SubContext: TWatchExpTestCurrentData;
v, n, tn: String;
parsed: TStringArray;
i, e, j: Integer;
ehf: TWatchExpErrorHandlingFlags; ehf: TWatchExpErrorHandlingFlags;
Expect: TWatchExpectationResult;
begin begin
with AContext.WatchExp do begin with AContext.WatchExp do begin
Result := True; Result := True;
@ -1802,61 +1879,20 @@ begin
if not TestMatches('Is class ', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then if not TestMatches('Is class ', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then
exit; exit;
delete(v, 1, pos('(', v)); Result := CheckStructureFields(AnIgnoreRsn, AContext);
delete(v, length(v), 1);
parsed := ParseCommaList(v, e, -1, ';');
TestTrue('FieldParser len', e <= Length(parsed), AContext, AnIgnoreRsn);
e := min(e, Length(parsed));
n := FTest.TestBaseName;
SubContext := AContext;
for i := 0 to length(Expect.ExpSubResults) - 1 do begin
sr := Expect.ExpSubResults[i];
if not TestTrue('field name '+IntToStr(i), sr.ExpFieldName<>'', AContext, AnIgnoreRsn) then
Continue;
j := parsed.IndexOfFieldName(sr.ExpFieldName, e);
if not TestTrue('field exists '+IntToStr(i), j >= 0, AContext, AnIgnoreRsn) then
Continue;
if not(ehNoFieldOrder in ehf) then begin
if ehMissingFields in ehf then begin
dec(e, j);
parsed.delete(0, j);
j := 0;
end;
if not TestTrue('field in order '+IntToStr(i)+' '+IntToStr(j), j = 0, AContext, AnIgnoreRsn) then
Continue;
end;
SubContext.WatchVal.Value := parsed.ValueOfFieldName(j);
FTest.TestBaseName := n + ' Idx='+IntToStr(i);
dec(e);
parsed.delete(j, 1);
//SubContext.WatchExp.TstExpected := sr;
SubContext.Expectation := sr;
Result := CheckData(SubContext, AnIgnoreRsn);
end;
FTest.TestBaseName := n;
AContext.WatchVal.Value := v;
end; end;
end; end;
function TWatchExpectationList.CheckResultObject( function TWatchExpectationList.CheckResultObject(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
begin begin
CheckResultRecord(AContext, AnIgnoreRsn); Result := CheckResultRecord(AContext, AnIgnoreRsn);
end; end;
function TWatchExpectationList.CheckResultInstance( function TWatchExpectationList.CheckResultInstance(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
begin begin
CheckResultClass(AContext, AnIgnoreRsn); Result := CheckResultClass(AContext, AnIgnoreRsn);
end; end;
constructor TWatchExpectationList.Create(ATest: TDBGTestCase); constructor TWatchExpectationList.Create(ATest: TDBGTestCase);
@ -1962,8 +1998,10 @@ procedure TWatchExpectationList.Clear;
var var
i: Integer; i: Integer;
begin begin
for i := 0 to Length(FList)-1 do for i := 0 to Length(FList)-1 do begin
FList[i].TstWatch.Free; FList[i].TstWatch.Free;
FList[i].EvalCallResDBGType.Free;
end;
FList := nil; FList := nil;
end; end;
@ -1978,7 +2016,7 @@ var
begin begin
t := LazDebugger.Threads.CurrentThreads.CurrentThreadId; t := LazDebugger.Threads.CurrentThreads.CurrentThreadId;
for i := 0 to Length(FList)-1 do begin for i := 0 to Length(FList)-1 do begin
EvaluateWatch(FList[i], t); EvaluateWatch(@FList[i], t);
if (i mod 16) = 0 then TestLogger.DbgOut('.'); if (i mod 16) = 0 then TestLogger.DbgOut('.');
end; end;
TestLogger.DebugLn(''); TestLogger.DebugLn('');