From 0ea8345dd4a7592ad6bcd6eb470125f07fe95efb Mon Sep 17 00:00:00 2001 From: martin Date: Wed, 18 Sep 2019 22:14:04 +0000 Subject: [PATCH] FpDebug: tests git-svn-id: trunk@61901 - --- .../lazdebuggerfp/test/testwatches.pas | 46 ++++ .../testapps/WatchesValuePrg.pas | 59 ++++- .../testapps/WatchesValuePrgIdent.inc | 9 +- .../lazdebugtestbase/ttestwatchutilities.pas | 250 ++++++++++-------- 4 files changed, 254 insertions(+), 110 deletions(-) diff --git a/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas b/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas index 7baa6eab5a..16d73ca893 100644 --- a/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas +++ b/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas @@ -1518,6 +1518,7 @@ procedure TTestWatches.TestWatchesTypeCast; var p, e, val: String; Thread, n, StartIdx, i: Integer; + we: PWatchExpectation; begin p := APrefix; n := AOffs; @@ -1606,6 +1607,46 @@ for i := StartIdx to t.Count-1 do 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+' QWord', 'QWord('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError(); @@ -1648,6 +1689,11 @@ begin (* ************ Nested Functions ************* *) 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; AddWatchesConv(t, 'glob const', 'gc', 000, 'A', tlConst); diff --git a/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas b/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas index c714acc32b..f9d031cc93 100644 --- a/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas +++ b/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas @@ -16,6 +16,9 @@ begin result := SomeValue = 0; end; procedure SomeProc1(); begin SomeFunc1(2,2,2,2); end; +const + MaxListSize = high(longword) div 16; + type {$ifdef CPU64} PtrUInt = type QWord; @@ -25,12 +28,17 @@ type PtrUInt = type DWord; {$endif CPU32} + PPointerList = ^TPointerList; + TPointerList = array[0..MaxListSize - 1] of Pointer; + var BreakDummy: PtrUInt; p: Pointer; InterfacedObject, InterfacedObject2: TInterfacedObject; type + TClass1 = class; + TIntRange = -300..300; TCardinalRange = 1..300; @@ -106,6 +114,8 @@ type TRecFivePackStatArray = array [2..4] of TRecordFivePack; TRecFivePackStatPackArray = packed array [2..4] of TRecordFivePack; + TRecordClass1 = record Foo: TClass1; end; + TClass1 = class public FInt: integer; @@ -131,22 +141,28 @@ type type (* LOCATION: TYPE *) + // type TxByte: type Byte; 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 ) //} + // type PxByte: ^Byte; TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=Px, "_OP_==^", "_O2_==^", "(=;//", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) //} + (* LOCATION: field in baseclass *) TMyBaseClass = class public function SomeMeth1(SomeValue: Integer): Boolean; public + // mbcByte: Byte; TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mbc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar ) end; (* LOCATION: field in class *) TMyClass = class(TMyBaseClass) public + // mcByte: Byte; TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar ) end; @@ -154,29 +170,51 @@ var MyClass1: TMyClass; MyClass2: TMyBaseClass; (* LOCATION: field, requires typecast of containing class *) + 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) var (* LOCATION: global var *) + // gvByte: Byte = (1 + add); 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 *) + // gvaByte: array of Byte; TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gva, "_OP_=: array of", (=;//, "_O2_=: array of", _EQ_=, _BLOCK_=TestVar ) (* LOCATION: global var pointer *) + // gvp_Byte: ^Byte; TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvp_, "_OP_=: ^", (=;//, "_O2_=: ^", _EQ_=, _BLOCK_=TestVar, _BLOCK2_=TestPointer ) (* 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 ) // } (* LOCATION: global var NAMED pointer // NO PRE-ASSIGNED VALUE *) + // gvtt_Byte: TxByte; TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=gvtt_, "_OP_={", "_O2_={", "//@@=} :", _pre3_=Tx, _BLOCK_=TestVar, _BLOCK2_=TestType ) // } (* LOCATION: global var NAMED pointer // NO PRE-ASSIGNED VALUE *) + // gvptt_Byte: PTxByte; 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; begin end; destructor TObjectCreate3Int64.Destroy; @@ -266,17 +304,32 @@ begin TEST_PREPOCESS(WatchesValuePrgIdent.inc,pre__=gv, {e}={, "//@@=} :=", _pre3_=gc, _BLOCK_=TestAssignGC) (* 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 *) - 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 // 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 // NO PRE-ASSIGNED VALUE *) 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 *) MyClass1 := TMyClass.Create; MyClass1.SomeMeth1(1); diff --git a/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc b/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc index 683cd37934..54e4858a57 100644 --- a/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc +++ b/components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc @@ -383,7 +383,6 @@ 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; - {$IFnDEF TestConst} {$IFnDEF TestAssignGC} {$IFnDEF TestType} // will work in fpc 3.2.0 upwards @@ -443,6 +442,14 @@ {$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__SomeProc1Ref{e} _O2_ TProc1 _EQ_ (nil); //@@ _pre3_SomeProc1Ref; diff --git a/components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas b/components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas index 485fb83afd..2d96802897 100644 --- a/components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas +++ b/components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas @@ -130,6 +130,12 @@ type TstTestName: String; TstWatch: TTestWatch; + EvalCallTestFlags: TDBGEvaluateFlags; + EvalCallResReceived: Boolean; + EvalCallResSuccess: Boolean; + EvalCallResText: String; + EvalCallResDBGType: TDBGType; + //TstDspFormat: TWatchDisplayFormat; //TstRepeatCount: Integer; //TstEvaluateFlags: TDBGEvaluateFlags; @@ -192,6 +198,10 @@ type FTest: TDBGTestCase; FList: array of TWatchExpectation; FTypeNameAliases: TStringList; + + FCurEvalCallWatchExp: PWatchExpectation; + procedure EvalCallback(Sender: TObject; ASuccess: Boolean; + ResultText: String; ResultDBGType: TDBGType); function GetCompiler: TTestDbgCompiler; function GetDebugger: TTestDbgDebugger; function GetLazDebugger: TDebuggerIntf; @@ -199,7 +209,7 @@ type function ParseCommaList(AVal: String; out AFoundCount: Integer; AMaxLen: Integer = -1; AComma: char = ','): TStringArray; protected - function EvaluateWatch(AWatchExp: TWatchExpectation; AThreadId: Integer): Boolean; virtual; + function EvaluateWatch(AWatchExp: PWatchExpectation; AThreadId: Integer): Boolean; virtual; procedure WaitWhileEval; virtual; 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 CheckResultPointerAddr(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 CheckResultClass(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; function CheckResultObject(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual; @@ -1071,25 +1082,57 @@ begin 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; var i: Integer; begin with LazDebugger.GetLocation do - FTest.LogText('###### ' + AWatchExp.TstTestName + ' // ' + AWatchExp.TstWatch.Expression + + FTest.LogText('###### ' + AWatchExp^.TstTestName + ' // ' + AWatchExp^.TstWatch.Expression + ' (AT '+ SrcFile + ':' + IntToStr(SrcLine) +')' + '###### '+LineEnding); - AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Value; + AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Value; for i := 1 to 5 do begin 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; WaitWhileEval; end; - FTest.LogText('<<<<< ' + dbgs(AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Validity) + ': ' + - AWatchExp.TstWatch.Values[AThreadId, AWatchExp.TstStackFrame].Value ); + FTest.LogText('<<<<< ' + dbgs(AWatchExp^.TstWatch.Values[AThreadId, AWatchExp^.TstStackFrame].Validity) + ': ' + + 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; procedure TWatchExpectationList.WaitWhileEval; @@ -1201,6 +1244,12 @@ begin then 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); VerifyTypeName(Context, AnIgnoreRsn); @@ -1308,7 +1357,7 @@ begin Result := True; Expect := AContext.Expectation; - if (Expect.ExpTypeName = '') or (not AContext.HasTypeInfo) then + if (Expect.ExpTypeName = '') or (Expect.ExpTypeName = #1) or (not AContext.HasTypeInfo) then exit; ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType]; @@ -1703,14 +1752,86 @@ debugln([' expect ',Expect.ExpFullArrayLen,' got "',v,'"' ]); 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( AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; var - Expect, sr: TWatchExpectationResult; - SubContext: TWatchExpTestCurrentData; - v, n, tn: String; - parsed: TStringArray; - i, e, j: Integer; + Expect: TWatchExpectationResult; + v, tn: String; ehf: TWatchExpErrorHandlingFlags; 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 exit; - 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; - - 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; + Result := CheckStructureFields(AnIgnoreRsn, AContext); end; end; function TWatchExpectationList.CheckResultClass( AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; var - Expect, sr: TWatchExpectationResult; - SubContext: TWatchExpTestCurrentData; - v, n, tn: String; - parsed: TStringArray; - i, e, j: Integer; + v, tn: String; ehf: TWatchExpErrorHandlingFlags; + Expect: TWatchExpectationResult; begin with AContext.WatchExp do begin Result := True; @@ -1802,61 +1879,20 @@ begin if not TestMatches('Is class ', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then exit; - 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; - - 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; + Result := CheckStructureFields(AnIgnoreRsn, AContext); end; end; function TWatchExpectationList.CheckResultObject( AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; begin - CheckResultRecord(AContext, AnIgnoreRsn); + Result := CheckResultRecord(AContext, AnIgnoreRsn); end; function TWatchExpectationList.CheckResultInstance( AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; begin - CheckResultClass(AContext, AnIgnoreRsn); + Result := CheckResultClass(AContext, AnIgnoreRsn); end; constructor TWatchExpectationList.Create(ATest: TDBGTestCase); @@ -1962,8 +1998,10 @@ procedure TWatchExpectationList.Clear; var i: Integer; begin - for i := 0 to Length(FList)-1 do + for i := 0 to Length(FList)-1 do begin FList[i].TstWatch.Free; + FList[i].EvalCallResDBGType.Free; + end; FList := nil; end; @@ -1978,7 +2016,7 @@ var begin t := LazDebugger.Threads.CurrentThreads.CurrentThreadId; 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('.'); end; TestLogger.DebugLn('');