mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-16 23:49:28 +02:00
GdbmiDebugger, test: more output, to compare test results
git-svn-id: trunk@64959 -
This commit is contained in:
martin
parent
05d6300123
commit
caeb20c1c4
@ -321,13 +321,13 @@ begin
|
||||
i := high(QWord) - FStartTime + 1 + i;
|
||||
|
||||
if FTotalGDBInternalErrorCnt > 0
|
||||
then Result := Result + '.gdb_intern_'+IntToStr(FTotalGDBInternalErrorCnt);
|
||||
then Result := Result + '___gdb_intern.'+IntToStr(FTotalGDBInternalErrorCnt);
|
||||
if FTotalDsErrorCrash > 0
|
||||
then Result := Result + '.gdb_crash_'+IntToStr(FTotalDsErrorCrash);
|
||||
then Result := Result + '___gdb_crash.'+IntToStr(FTotalDsErrorCrash);
|
||||
if FTotalClassVsRecord > 0
|
||||
then Result := Result + '.class_rec_'+IntToStr(FTotalClassVsRecord);
|
||||
then Result := Result + '___class_re._'+IntToStr(FTotalClassVsRecord);
|
||||
|
||||
Result := Result + '.t_'+ IntToStr(i div 1000);
|
||||
// Result := Result + '___time.'+ IntToStr(i div 1000);
|
||||
end;
|
||||
|
||||
function TGDBTestCase.StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;
|
||||
|
||||
@ -407,125 +407,130 @@ var
|
||||
end;
|
||||
|
||||
begin
|
||||
if not TestTrue('Dbg did NOT enter dsError', ADbg.State <> dsError) then exit;
|
||||
if Data.OnBeforeTest <> nil then Data.OnBeforeTest(@Data);
|
||||
StartTestBlock;
|
||||
try
|
||||
if not TestTrue('Dbg did NOT enter dsError', ADbg.State <> dsError) then exit;
|
||||
if Data.OnBeforeTest <> nil then Data.OnBeforeTest(@Data);
|
||||
|
||||
rx := nil;
|
||||
Stack := Data.StackFrame;
|
||||
DataRes := Data.Result[SymbolType];
|
||||
IgnoreFlags := DataRes.Flgs * WatchExpFlagMask[SymbolType];
|
||||
IgnoreAll := IgnoreFlags * WatchExpFlagSIgnAll <> [];
|
||||
IgnoreData := IgnoreFlags * WatchExpFlagSIgnData <> [];
|
||||
IgnoreKind := IgnoreFlags * WatchExpFlagSIgnKind <> [];
|
||||
IgnoreKindPtr := IgnoreFlags * WatchExpFlagSIgnKindPtr <> [];
|
||||
IgnoreTpName := IgnoreFlags * WatchExpFlagSIgnTpName <> [];
|
||||
rx := nil;
|
||||
Stack := Data.StackFrame;
|
||||
DataRes := Data.Result[SymbolType];
|
||||
IgnoreFlags := DataRes.Flgs * WatchExpFlagMask[SymbolType];
|
||||
IgnoreAll := IgnoreFlags * WatchExpFlagSIgnAll <> [];
|
||||
IgnoreData := IgnoreFlags * WatchExpFlagSIgnData <> [];
|
||||
IgnoreKind := IgnoreFlags * WatchExpFlagSIgnKind <> [];
|
||||
IgnoreKindPtr := IgnoreFlags * WatchExpFlagSIgnKindPtr <> [];
|
||||
IgnoreTpName := IgnoreFlags * WatchExpFlagSIgnTpName <> [];
|
||||
|
||||
// Get Value
|
||||
n := Data.TestName;
|
||||
if n = '' then n := Data.Expression + ' (' + TWatchDisplayFormatNames[Data.DspFormat] + ', ' + dbgs(Data.EvaluateFlags) + ' RepCnt=' + dbgs(Data.RepeatCount) + ')';
|
||||
Name := Name + ' ' + n + ' ::: '+adbg.GetLocation.SrcFile+' '+IntToStr(ADbg.GetLocation.SrcLine);
|
||||
LogToFile('###### ' + Name + '###### '+LineEnding);
|
||||
flag := AWatch <> nil; // test for typeinfo/kind // Awatch=nil > direct gdb command
|
||||
IsValid := True;
|
||||
HasTpInfo := True;
|
||||
if flag then begin;
|
||||
WV := AWatch.Values[1, Stack];// trigger read
|
||||
s := WV.Value;
|
||||
IsValid := WV.Validity = ddsValid;
|
||||
HasTpInfo := IsValid and (WV.TypeInfo <> nil);
|
||||
// flag := flag and IsValid;
|
||||
end
|
||||
else
|
||||
s := WatchValue;
|
||||
|
||||
if not TestTrue('ADbg did NOT enter dsError', ADbg.State <> dsError) then exit;
|
||||
|
||||
// Check Data
|
||||
f2 := True;
|
||||
IgnoreText := ''; if IgnoreData then IgnoreText := 'Ignored by flag';
|
||||
if IsValid = not(fTExpectError in DataRes.Flgs) then begin
|
||||
rx := TRegExpr.Create;
|
||||
rx.ModifierI := true;
|
||||
rx.Expression := DataRes.ExpMatch;
|
||||
if DataRes.ExpMatch <> ''
|
||||
then f2 := TestTrue(Name + ' Matches "'+DataRes.ExpMatch + '", but was "' + s + '"', rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
FreeAndNil(rx);
|
||||
end else begin
|
||||
f2 := TestTrue(Name + ' Matches "'+DataRes.ExpMatch + '", but STATE was <'+dbgs(WV.Validity)+'> Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
//exit; // failed Data, do not list others as potential unexpected success
|
||||
end;
|
||||
|
||||
if (not f2) and IgnoreAll then exit; // failed Data, do not list others as potential unexpected success
|
||||
|
||||
// TypeInfo checks ?
|
||||
if (not flag) or (DataRes.ExpTypeName = '') then exit;
|
||||
|
||||
// Check TypeInfo
|
||||
s:='';
|
||||
if HasTpInfo then WriteStr(s, WV.TypeInfo.Kind);
|
||||
WriteStr(s2, DataRes.ExpKind);
|
||||
IgnoreText := ''; if IgnoreKind then IgnoreText := 'Ignored by flag';
|
||||
if IsValid and HasTpInfo then begin
|
||||
if (not IgnoreKind) and IgnoreKindPtr and (WV.TypeInfo.Kind = skPointer) then IgnoreText := 'Ignored by flag (Kind may be Ptr)';
|
||||
f2 := TestEquals(Name + ' Kind', s2, s, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
if ((s2='skClass') and (s = 'skRecord')) or ((s='skClass') and (s2 = 'skRecord')) then begin
|
||||
TotalClassVsRecord := TotalClassVsRecord + 1;
|
||||
end;
|
||||
end else begin
|
||||
f2 := TestTrue(Name + ' Kind is "'+s2+'", failed: STATE was <'+dbgs(WV.Validity)+'>, HasTypeInfo='+dbgs(HasTpInfo)+' Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
|
||||
if (not f2) and IgnoreAll then exit; // failed Data, do not list others as potential unexpected success
|
||||
|
||||
// Check TypeName
|
||||
IgnoreText := ''; if IgnoreTpName then IgnoreText := 'Ignored by flag';
|
||||
if IsValid and HasTpInfo then begin
|
||||
s:='';
|
||||
if HasTpInfo then s := WV.TypeInfo.TypeName;
|
||||
CmpNames(Name+' TypeName', DataRes.ExpTypeName, s, fTpMtch in DataRes.Flgs);
|
||||
//if fTpMtch in DataRes.Flgs
|
||||
//then begin
|
||||
// rx := TRegExpr.Create;
|
||||
// rx.ModifierI := true;
|
||||
// rx.Expression := DataRes.ExpTypeName;
|
||||
// TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but was '+s, rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
// FreeAndNil(rx);
|
||||
// end
|
||||
// else TestEquals(Name + ' TypeName', LowerCase(DataRes.ExpTypeName), LowerCase(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end else begin
|
||||
TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but STATE was <'+dbgs(WV.Validity)+'> HasTypeInfo='+dbgs(HasTpInfo)+' Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
|
||||
|
||||
MemberTests := DataRes.FullTypesExpect;
|
||||
if Length(MemberTests) > 0 then begin
|
||||
if HasTpInfo then begin
|
||||
for i := 0 to Length(MemberTests) - 1 do begin
|
||||
j := WV.TypeInfo.Fields.Count - 1;
|
||||
while (j >= 0) and (CompareText(WV.TypeInfo.Fields[j].Name, MemberTests[i].Name) <> 0) do dec(j);
|
||||
TestTrue(Name + ' no members with name ' + MemberTests[i].Name,
|
||||
(fTExpectNotFOund in MemberTests[i].Flgs) <> (j >= 0),
|
||||
DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
if j >= 0 then begin
|
||||
fld := WV.TypeInfo.Fields[j];
|
||||
WriteStr(s, MemberTests[i].ExpKind);
|
||||
WriteStr(s2, fld.DBGType.Kind);
|
||||
if fld.DBGType <> nil then begin
|
||||
TestTrue(Name + ' members with name ' + MemberTests[i].Name + ' type='
|
||||
+ s + ' but was ' + s2,
|
||||
MemberTests[i].ExpKind = fld.DBGType.Kind, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
CmpNames(Name + ' members with name ' + MemberTests[i].Name + 'TypeName',
|
||||
MemberTests[i].ExpTypeName, fld.DBGType.TypeName, fTpMtch in MemberTests[i].Flgs);
|
||||
end
|
||||
else
|
||||
TestTrue(Name + ' no dbgtype for members with name' + MemberTests[i].Name, False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
end;
|
||||
end;
|
||||
// Get Value
|
||||
n := Data.TestName;
|
||||
if n = '' then n := Data.Expression + ' (' + TWatchDisplayFormatNames[Data.DspFormat] + ', ' + dbgs(Data.EvaluateFlags) + ' RepCnt=' + dbgs(Data.RepeatCount) + ')';
|
||||
Name := Name + ' ' + n + ' ::: '+adbg.GetLocation.SrcFile+' '+IntToStr(ADbg.GetLocation.SrcLine);
|
||||
LogToFile('###### ' + Name + '###### '+LineEnding);
|
||||
flag := AWatch <> nil; // test for typeinfo/kind // Awatch=nil > direct gdb command
|
||||
IsValid := True;
|
||||
HasTpInfo := True;
|
||||
if flag then begin;
|
||||
WV := AWatch.Values[1, Stack];// trigger read
|
||||
s := WV.Value;
|
||||
IsValid := WV.Validity = ddsValid;
|
||||
HasTpInfo := IsValid and (WV.TypeInfo <> nil);
|
||||
// flag := flag and IsValid;
|
||||
end
|
||||
else
|
||||
TestTrue(Name + ' no typeinfo for members' , False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
s := WatchValue;
|
||||
|
||||
if not TestTrue('ADbg did NOT enter dsError', ADbg.State <> dsError) then exit;
|
||||
|
||||
// Check Data
|
||||
f2 := True;
|
||||
IgnoreText := ''; if IgnoreData then IgnoreText := 'Ignored by flag';
|
||||
if IsValid = not(fTExpectError in DataRes.Flgs) then begin
|
||||
rx := TRegExpr.Create;
|
||||
rx.ModifierI := true;
|
||||
rx.Expression := DataRes.ExpMatch;
|
||||
if DataRes.ExpMatch <> ''
|
||||
then f2 := TestTrue(Name + ' Matches "'+DataRes.ExpMatch + '", but was "' + s + '"', rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
FreeAndNil(rx);
|
||||
end else begin
|
||||
f2 := TestTrue(Name + ' Matches "'+DataRes.ExpMatch + '", but STATE was <'+dbgs(WV.Validity)+'> Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
//exit; // failed Data, do not list others as potential unexpected success
|
||||
end;
|
||||
|
||||
if (not f2) and IgnoreAll then exit; // failed Data, do not list others as potential unexpected success
|
||||
|
||||
// TypeInfo checks ?
|
||||
if (not flag) or (DataRes.ExpTypeName = '') then exit;
|
||||
|
||||
// Check TypeInfo
|
||||
s:='';
|
||||
if HasTpInfo then WriteStr(s, WV.TypeInfo.Kind);
|
||||
WriteStr(s2, DataRes.ExpKind);
|
||||
IgnoreText := ''; if IgnoreKind then IgnoreText := 'Ignored by flag';
|
||||
if IsValid and HasTpInfo then begin
|
||||
if (not IgnoreKind) and IgnoreKindPtr and (WV.TypeInfo.Kind = skPointer) then IgnoreText := 'Ignored by flag (Kind may be Ptr)';
|
||||
f2 := TestEquals(Name + ' Kind', s2, s, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
if ((s2='skClass') and (s = 'skRecord')) or ((s='skClass') and (s2 = 'skRecord')) then begin
|
||||
TotalClassVsRecord := TotalClassVsRecord + 1;
|
||||
end;
|
||||
end else begin
|
||||
f2 := TestTrue(Name + ' Kind is "'+s2+'", failed: STATE was <'+dbgs(WV.Validity)+'>, HasTypeInfo='+dbgs(HasTpInfo)+' Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
|
||||
if (not f2) and IgnoreAll then exit; // failed Data, do not list others as potential unexpected success
|
||||
|
||||
// Check TypeName
|
||||
IgnoreText := ''; if IgnoreTpName then IgnoreText := 'Ignored by flag';
|
||||
if IsValid and HasTpInfo then begin
|
||||
s:='';
|
||||
if HasTpInfo then s := WV.TypeInfo.TypeName;
|
||||
CmpNames(Name+' TypeName', DataRes.ExpTypeName, s, fTpMtch in DataRes.Flgs);
|
||||
//if fTpMtch in DataRes.Flgs
|
||||
//then begin
|
||||
// rx := TRegExpr.Create;
|
||||
// rx.ModifierI := true;
|
||||
// rx.Expression := DataRes.ExpTypeName;
|
||||
// TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but was '+s, rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
// FreeAndNil(rx);
|
||||
// end
|
||||
// else TestEquals(Name + ' TypeName', LowerCase(DataRes.ExpTypeName), LowerCase(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end else begin
|
||||
TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but STATE was <'+dbgs(WV.Validity)+'> HasTypeInfo='+dbgs(HasTpInfo)+' Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
|
||||
|
||||
MemberTests := DataRes.FullTypesExpect;
|
||||
if Length(MemberTests) > 0 then begin
|
||||
if HasTpInfo then begin
|
||||
for i := 0 to Length(MemberTests) - 1 do begin
|
||||
j := WV.TypeInfo.Fields.Count - 1;
|
||||
while (j >= 0) and (CompareText(WV.TypeInfo.Fields[j].Name, MemberTests[i].Name) <> 0) do dec(j);
|
||||
TestTrue(Name + ' no members with name ' + MemberTests[i].Name,
|
||||
(fTExpectNotFOund in MemberTests[i].Flgs) <> (j >= 0),
|
||||
DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
if j >= 0 then begin
|
||||
fld := WV.TypeInfo.Fields[j];
|
||||
WriteStr(s, MemberTests[i].ExpKind);
|
||||
WriteStr(s2, fld.DBGType.Kind);
|
||||
if fld.DBGType <> nil then begin
|
||||
TestTrue(Name + ' members with name ' + MemberTests[i].Name + ' type='
|
||||
+ s + ' but was ' + s2,
|
||||
MemberTests[i].ExpKind = fld.DBGType.Kind, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
CmpNames(Name + ' members with name ' + MemberTests[i].Name + 'TypeName',
|
||||
MemberTests[i].ExpTypeName, fld.DBGType.TypeName, fTpMtch in MemberTests[i].Flgs);
|
||||
end
|
||||
else
|
||||
TestTrue(Name + ' no dbgtype for members with name' + MemberTests[i].Name, False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
TestTrue(Name + ' no typeinfo for members' , False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
|
||||
end;
|
||||
|
||||
finally
|
||||
EndTestBlock;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestWatchesBase.AddWatches(ExpectList: TWatchExpectationArray; AWatches: TWatches;
|
||||
|
||||
@ -996,8 +996,8 @@ end;
|
||||
|
||||
initialization
|
||||
RegisterDbgTest(TTestExceptionAddrDirect);
|
||||
RegisterDbgTest(TTestExceptionAddrInDirect);
|
||||
RegisterDbgTest(TTestExceptionForceName);
|
||||
RegisterDbgTest(TTestExceptionAddrInDirect, [stDwarfSet, stStabs]);
|
||||
RegisterDbgTest(TTestExceptionForceName, [stDwarfSet, stStabs]);
|
||||
|
||||
ControlTestExceptionOne := TestControlRegisterTest('TTestExceptionOne');
|
||||
ControlTestExceptionOneException := TestControlRegisterTest('Exception', ControlTestExceptionOne);
|
||||
|
||||
@ -36,6 +36,8 @@ var
|
||||
SetLogPathProc: TSetLogPath;
|
||||
GetLogPathProc: TGetLogPath;
|
||||
GetWriteLogProc: TGetWriteLog;
|
||||
GetWriteReportProc: TGetWriteLog;
|
||||
GetWriteOverviewProc: TGetWriteLog;
|
||||
RegisterCompilerProc: TRegisterCompiler;
|
||||
RegisterDebuggerProc: TRegisterDebugger;
|
||||
RegisterTestProc: TRegisterTest;
|
||||
@ -54,6 +56,8 @@ function TestControlRegisterTest(Name: String; Parent: Pointer = nil): Pointer;
|
||||
procedure TestControlSetLogPath(path: string);
|
||||
function TestControlGetLogPath: string;
|
||||
function TestControlGetWriteLog: TWriteLogConfig;
|
||||
function TestControlGetWriteReport: TWriteLogConfig;
|
||||
function TestControlGetWriteOverView: TWriteLogConfig;
|
||||
|
||||
procedure TestControlRegisterCompilers(c: TBaseList);
|
||||
procedure TestControlRegisterDebuggers(d: TBaseList);
|
||||
@ -151,6 +155,22 @@ begin
|
||||
Result := wlAlways;
|
||||
end;
|
||||
|
||||
function TestControlGetWriteReport: TWriteLogConfig;
|
||||
begin
|
||||
Result := wlNever;
|
||||
if GetWriteReportProc <> nil then
|
||||
Result := GetWriteReportProc();
|
||||
if (Result = wlOnError) and (TestControlGetWriteLog = wlAlways) then
|
||||
Result := wlAlways;
|
||||
end;
|
||||
|
||||
function TestControlGetWriteOverView: TWriteLogConfig;
|
||||
begin
|
||||
Result := wlNever;
|
||||
if GetWriteOverviewProc <> nil then
|
||||
Result := GetWriteOverviewProc();
|
||||
end;
|
||||
|
||||
procedure TestControlRegisterCompilers(c: TBaseList);
|
||||
var
|
||||
i: Integer;
|
||||
|
||||
@ -77,6 +77,32 @@ object DbgTestControlForm: TDbgTestControlForm
|
||||
MaxLength = 0
|
||||
TabOrder = 2
|
||||
end
|
||||
object CheckWriteReport: TCheckBox
|
||||
AnchorSideLeft.Control = WriteLogsOnErr
|
||||
AnchorSideLeft.Side = asrBottom
|
||||
AnchorSideTop.Control = CheckWriteLogs
|
||||
Left = 216
|
||||
Height = 19
|
||||
Top = 1
|
||||
Width = 91
|
||||
BorderSpacing.Left = 6
|
||||
Caption = 'Write Reports'
|
||||
OnChange = CheckWriteReportChange
|
||||
TabOrder = 3
|
||||
end
|
||||
object CheckWriteOverview: TCheckBox
|
||||
AnchorSideLeft.Control = CheckWriteReport
|
||||
AnchorSideLeft.Side = asrBottom
|
||||
AnchorSideTop.Control = CheckWriteLogs
|
||||
Left = 313
|
||||
Height = 19
|
||||
Top = 1
|
||||
Width = 100
|
||||
BorderSpacing.Left = 6
|
||||
Caption = 'Write Overview'
|
||||
OnChange = CheckWriteOverviewChange
|
||||
TabOrder = 4
|
||||
end
|
||||
end
|
||||
object Panel2: TPanel
|
||||
Left = 0
|
||||
@ -265,74 +291,13 @@ object DbgTestControlForm: TDbgTestControlForm
|
||||
end
|
||||
end
|
||||
object ilNodeStates: TImageList
|
||||
left = 220
|
||||
top = 380
|
||||
Left = 220
|
||||
Top = 380
|
||||
Bitmap = {
|
||||
4C69020000001000000010000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FF000000FFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFF0000
|
||||
00FFFFFFFFFFFFFFFFFFFFFFFFFF000000FF000000FF000000FFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF000000FF000000FF000000FFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFF0000
|
||||
00FF000000FF000000FF000000FF000000FFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFF000000FF000000FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000
|
||||
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
|
||||
00FF000000FFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000
|
||||
4C7A020000001000000010000000520000000000000078DAFBFF9F7CC0000450
|
||||
9A644C0BFD44BA7954FFA8FE41957E29C97F9482FFA3F99F28FD487A48D68FA6
|
||||
07AF7E7473B0F899A07E7436B299C4EAC7A69758FFE3D24B4AF8E10ACFD1FC4F
|
||||
DDFC0F003436B484
|
||||
}
|
||||
end
|
||||
end
|
||||
|
||||
@ -16,6 +16,8 @@ type
|
||||
{ TDbgTestControlForm }
|
||||
|
||||
TDbgTestControlForm = class(TForm)
|
||||
CheckWriteReport: TCheckBox;
|
||||
CheckWriteOverview: TCheckBox;
|
||||
chkDbg: TTreeView;
|
||||
chkFpc: TTreeView;
|
||||
chkSym: TCheckListBox;
|
||||
@ -51,11 +53,13 @@ type
|
||||
procedure btnTestAllClick(Sender: TObject);
|
||||
procedure btnTestNoneClick(Sender: TObject);
|
||||
procedure CheckWriteLogsChange(Sender: TObject);
|
||||
procedure CheckWriteOverviewChange(Sender: TObject);
|
||||
procedure CheckWriteReportChange(Sender: TObject);
|
||||
procedure chkTestsMouseDown(Sender: TObject; Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
private
|
||||
FWriteLogValCache: TWriteLogConfig;
|
||||
FWriteLogIsCached: Boolean;
|
||||
FWriteLogValCache, FWriteReportValCache, FWriteOverViewValCache: TWriteLogConfig;
|
||||
FWriteLogIsCached, FWriteReportIsCached, FWriteOverViewIsCached: Boolean;
|
||||
public
|
||||
procedure DbgShow(Data: PtrInt);
|
||||
end;
|
||||
@ -163,6 +167,34 @@ begin
|
||||
DbgTestControlForm.FWriteLogIsCached := True;
|
||||
end;
|
||||
|
||||
function GetWriteReport: TWriteLogConfig;
|
||||
begin
|
||||
if DbgTestControlForm.FWriteReportIsCached then begin
|
||||
Result := DbgTestControlForm.FWriteReportValCache;
|
||||
exit;
|
||||
end;
|
||||
Result := wlNever;
|
||||
if DbgTestControlForm.CheckWriteReport.Checked then
|
||||
Result := wlOnError;
|
||||
|
||||
DbgTestControlForm.FWriteReportValCache := Result;
|
||||
DbgTestControlForm.FWriteReportIsCached := True;
|
||||
end;
|
||||
|
||||
function GetWriteOverview: TWriteLogConfig;
|
||||
begin
|
||||
if DbgTestControlForm.FWriteOverViewIsCached then begin
|
||||
Result := DbgTestControlForm.FWriteOverViewValCache;
|
||||
exit;
|
||||
end;
|
||||
Result := wlNever;
|
||||
if DbgTestControlForm.CheckWriteOverview.Checked then
|
||||
Result := wlAlways;
|
||||
|
||||
DbgTestControlForm.FWriteOverViewValCache := Result;
|
||||
DbgTestControlForm.FWriteOverViewIsCached := True;
|
||||
end;
|
||||
|
||||
procedure RegisterCompiler(name: string);
|
||||
begin
|
||||
DbgTestControlForm.chkFpc.Items.Add(nil, Name)
|
||||
@ -259,6 +291,16 @@ begin
|
||||
FWriteLogIsCached := False;
|
||||
end;
|
||||
|
||||
procedure TDbgTestControlForm.CheckWriteOverviewChange(Sender: TObject);
|
||||
begin
|
||||
FWriteOverViewIsCached := False;
|
||||
end;
|
||||
|
||||
procedure TDbgTestControlForm.CheckWriteReportChange(Sender: TObject);
|
||||
begin
|
||||
FWriteReportIsCached := False;
|
||||
end;
|
||||
|
||||
procedure TDbgTestControlForm.DbgShow(Data: PtrInt);
|
||||
var
|
||||
s: TSymbolType;
|
||||
@ -293,6 +335,8 @@ initialization
|
||||
SetLogPathProc := @SetLogPath;
|
||||
GetLogPathProc := @GetLogPath;
|
||||
GetWriteLogProc := @GetWriteLog;
|
||||
GetWriteReportProc := @GetWriteReport;
|
||||
GetWriteOverviewProc := @GetWriteOverview;
|
||||
RegisterCompilerProc := @RegisterCompiler;
|
||||
RegisterDebuggerProc := @RegisterDebugger;
|
||||
RegisterTestProc := @RegisterTest;
|
||||
|
||||
@ -7,7 +7,7 @@ interface
|
||||
uses
|
||||
Classes, SysUtils, TTestDbgExecuteables, TestDbgControl, TestDbgConfig,
|
||||
TestOutputLogger, TestCommonSources, LazFileUtils, LazLogger,
|
||||
DbgIntfDebuggerBase, fpcunit, testregistry, RegExpr;
|
||||
DbgIntfDebuggerBase, StrUtils, fpcunit, testregistry, RegExpr;
|
||||
|
||||
const
|
||||
EqIgnoreCase = False; // for TestEquals(..., CaseSense, ...);
|
||||
@ -17,23 +17,45 @@ type
|
||||
TDBGTestsuite = class;
|
||||
TDBGStates = set of TDBGState;
|
||||
|
||||
{ TDbgBaseTestsuite }
|
||||
|
||||
TDbgBaseTestsuite = class(TTestSuite)
|
||||
private
|
||||
FInRun: Integer;
|
||||
FDirectParent: TDbgBaseTestsuite;
|
||||
FOverviewReport: String;
|
||||
procedure LogOverviewReport;
|
||||
protected
|
||||
procedure Clear; virtual;
|
||||
public
|
||||
procedure Run(AResult: TTestResult); override;
|
||||
procedure RunTest(ATest: TTest; AResult: TTestResult); override;
|
||||
procedure AddTest(ATest: TTest); overload; override;
|
||||
|
||||
procedure AddOverviewLog(Const AText: String);
|
||||
end;
|
||||
|
||||
{ TDBGTestCase }
|
||||
|
||||
TDBGTestCase = class(TTestCase)
|
||||
private
|
||||
FParent: TDBGTestsuite;
|
||||
FDirectParent: TDbgBaseTestsuite;
|
||||
// TestResults
|
||||
FTestBaseName: String;
|
||||
FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String;
|
||||
FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer;
|
||||
FInTestBlock: integer;
|
||||
FInTestBlockTxt: String;
|
||||
FInTestBlockRes: (tbOk, tbErr, tbIgnore, tbUnexpected);
|
||||
FTotalErrorCnt, FTotalIgnoredErrorCnt, FTotalUnexpectedSuccessCnt: Integer;
|
||||
FRegX: TRegExpr;
|
||||
|
||||
// Logging
|
||||
FLogLock: TRTLCriticalSection;
|
||||
FLogFile: TLazLoggerFileHandle;
|
||||
FLogFileCreated: Boolean;
|
||||
FLogFileName: String;
|
||||
FLogFile, FReportFile: TLazLoggerFileHandle;
|
||||
FLogFileCreated, FReportFileCreated: Boolean;
|
||||
FLogFileName, FReportFileName: String;
|
||||
FLogBufferText: TStringList;
|
||||
procedure InitLog;
|
||||
procedure FinishLog;
|
||||
@ -43,6 +65,8 @@ type
|
||||
protected
|
||||
FIgnoreReason: String;
|
||||
// TestResults
|
||||
procedure StartTestBlock;
|
||||
procedure EndTestBlock;
|
||||
procedure AddTestError (s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
|
||||
procedure AddTestError (s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
|
||||
procedure AddTestSuccess(s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
|
||||
@ -56,6 +80,7 @@ type
|
||||
function GetLogFileName: String; virtual;
|
||||
function GetFinalLogFileName: String; virtual;
|
||||
procedure CreateLog;
|
||||
procedure CreateReport;
|
||||
// Debugln
|
||||
procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); virtual;
|
||||
procedure DoDebugln(Sender: TObject; S: string; var Handled: Boolean); virtual;
|
||||
@ -117,7 +142,7 @@ type
|
||||
|
||||
{ TDBGTestWrapper }
|
||||
|
||||
TDBGTestWrapper = class(TTestSuite)
|
||||
TDBGTestWrapper = class(TDbgBaseTestsuite)
|
||||
private
|
||||
FParent: TDBGTestsuite;
|
||||
public
|
||||
@ -127,18 +152,13 @@ type
|
||||
|
||||
{ TDBGTestsuite }
|
||||
|
||||
TDBGTestsuite = class(TTestSuite)
|
||||
TDBGTestsuite = class(TDbgBaseTestsuite)
|
||||
private
|
||||
FCompiler: TTestDbgCompiler;
|
||||
FDebugger: TTestDbgDebugger;
|
||||
FInRun: Boolean;
|
||||
protected
|
||||
procedure Clear; virtual;
|
||||
public
|
||||
constructor Create(ACompiler: TTestDbgCompiler; ADebugger: TTestDbgDebugger); overload;
|
||||
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
|
||||
procedure Run(AResult: TTestResult); override;
|
||||
procedure RunTest(ATest: TTest; AResult: TTestResult); override;
|
||||
|
||||
property Compiler: TTestDbgCompiler read FCompiler;
|
||||
property Debugger: TTestDbgDebugger read FDebugger;
|
||||
@ -146,13 +166,93 @@ type
|
||||
|
||||
TDBGTestsuiteClass = class of TDBGTestsuite;
|
||||
|
||||
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
|
||||
procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes = []);
|
||||
|
||||
procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
|
||||
ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
|
||||
|
||||
implementation
|
||||
|
||||
{ TDbgBaseTestsuite }
|
||||
|
||||
procedure TDbgBaseTestsuite.LogOverviewReport;
|
||||
var
|
||||
oname: String;
|
||||
FOview: TextFile;
|
||||
begin
|
||||
if FOverviewReport = '' then
|
||||
exit;
|
||||
if TestControlGetWriteOverView = wlAlways then begin
|
||||
if DirectoryExistsUTF8(TestControlGetLogPath) then
|
||||
oname := TestControlGetLogPath
|
||||
else
|
||||
oname := GetCurrentDirUTF8;
|
||||
|
||||
oname := oname + 'overview_' +
|
||||
NameToFileName(DateTimeToStr(Now), False) +
|
||||
'.txt';
|
||||
AssignFile(FOView, oname);
|
||||
Rewrite(FOView);
|
||||
writeln(FOView, FOverviewReport);
|
||||
CloseFile(FOView);
|
||||
end;
|
||||
FOverviewReport := '';
|
||||
end;
|
||||
|
||||
procedure TDbgBaseTestsuite.Clear;
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
procedure TDbgBaseTestsuite.Run(AResult: TTestResult);
|
||||
begin
|
||||
inc(FInRun);
|
||||
try
|
||||
inherited Run(AResult);
|
||||
finally
|
||||
dec(FInRun);
|
||||
if FInRun = 0 then begin
|
||||
LogOverviewReport;
|
||||
end;
|
||||
Clear;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDbgBaseTestsuite.RunTest(ATest: TTest; AResult: TTestResult);
|
||||
begin
|
||||
inc(FInRun);
|
||||
try
|
||||
inherited RunTest(ATest, AResult);
|
||||
finally
|
||||
dec(FInRun);
|
||||
if FInRun = 0 then begin
|
||||
LogOverviewReport;
|
||||
Clear;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDbgBaseTestsuite.AddTest(ATest: TTest);
|
||||
begin
|
||||
inherited AddTest(ATest);
|
||||
if ATest is TDbgBaseTestsuite then
|
||||
TDbgBaseTestsuite(ATest).FDirectParent := Self
|
||||
else
|
||||
if ATest is TDBGTestCase then
|
||||
TDBGTestCase(ATest).FDirectParent := Self;
|
||||
end;
|
||||
|
||||
procedure TDbgBaseTestsuite.AddOverviewLog(const AText: String);
|
||||
begin
|
||||
if (FDirectParent <> nil) and (FDirectParent.FInRun > 0) then begin
|
||||
FDirectParent.AddOverviewLog(AText);
|
||||
exit;
|
||||
end;
|
||||
FOverviewReport := FOverviewReport + AText;
|
||||
if (FInRun = 0) then
|
||||
LogOverviewReport;
|
||||
end;
|
||||
|
||||
{ TDBGTestCase }
|
||||
|
||||
function TDBGTestCase.GetCompiler: TTestDbgCompiler;
|
||||
@ -165,6 +265,39 @@ begin
|
||||
Result := Parent.Debugger;
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.StartTestBlock;
|
||||
begin
|
||||
if FInTestBlock = 0 then begin
|
||||
inc(FTestCnt);
|
||||
FInTestBlockTxt := '';
|
||||
FInTestBlockRes := tbOk;
|
||||
end;
|
||||
inc(FInTestBlock);
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.EndTestBlock;
|
||||
begin
|
||||
dec(FInTestBlock);
|
||||
if FInTestBlock = 0 then begin
|
||||
case FInTestBlockRes of
|
||||
tbErr: begin
|
||||
FTestErrors := FTestErrors + FInTestBlockTxt;
|
||||
inc(FTestErrorCnt);
|
||||
end;
|
||||
tbIgnore: begin
|
||||
FIgnoredErrors := FIgnoredErrors + FInTestBlockTxt;
|
||||
inc(FIgnoredErrorCnt);
|
||||
end;
|
||||
tbUnexpected: begin
|
||||
FUnexpectedSuccess:= FUnexpectedSuccess + FInTestBlockTxt;
|
||||
inc(FUnexpectedSuccessCnt);
|
||||
end;
|
||||
end;
|
||||
FInTestBlockTxt := '';
|
||||
FInTestBlockRes := tbOk;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.AddTestError(s: string; MinDbgVers: Integer;
|
||||
AIgnoreReason: String);
|
||||
begin
|
||||
@ -177,7 +310,8 @@ var
|
||||
IgnoreReason: String;
|
||||
i: Integer;
|
||||
begin
|
||||
inc(FTestCnt);
|
||||
if FInTestBlock = 0 then
|
||||
inc(FTestCnt);
|
||||
IgnoreReason := '';
|
||||
s := FTestBaseName + s;
|
||||
if MinDbgVers > 0 then begin
|
||||
@ -194,13 +328,26 @@ begin
|
||||
if IgnoreReason = '' then
|
||||
IgnoreReason := FIgnoreReason;
|
||||
|
||||
if IgnoreReason <> '' then begin
|
||||
FIgnoredErrors := FIgnoredErrors + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
|
||||
inc(FIgnoredErrorCnt);
|
||||
end else begin
|
||||
FTestErrors := FTestErrors + IntToStr(FTestCnt) + ': ' + s + LineEnding;
|
||||
DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]);
|
||||
inc(FTestErrorCnt);
|
||||
if FInTestBlock > 0 then begin
|
||||
if IgnoreReason <> '' then begin
|
||||
FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
|
||||
if FInTestBlockRes in [tbOk, tbUnexpected] then
|
||||
FInTestBlockRes := tbIgnore;
|
||||
end else begin
|
||||
FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + s + LineEnding;
|
||||
FInTestBlockRes := tbErr;
|
||||
DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]);
|
||||
end;
|
||||
end
|
||||
else begin
|
||||
if IgnoreReason <> '' then begin
|
||||
FIgnoredErrors := FIgnoredErrors + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
|
||||
inc(FIgnoredErrorCnt);
|
||||
end else begin
|
||||
FTestErrors := FTestErrors + IntToStr(FTestCnt) + ': ' + s + LineEnding;
|
||||
DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]);
|
||||
inc(FTestErrorCnt);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -216,7 +363,8 @@ var
|
||||
i: Integer;
|
||||
begin
|
||||
s := FTestBaseName + s;
|
||||
inc(FTestCnt);
|
||||
if FInTestBlock = 0 then
|
||||
inc(FTestCnt);
|
||||
if (MinDbgVers > 0) then begin
|
||||
i := Debugger.Version;
|
||||
if (i > 0) and (i < MinDbgVers) then
|
||||
@ -232,8 +380,15 @@ begin
|
||||
|
||||
if AIgnoreReason <> '' then begin
|
||||
s := '[OK] ' + s;
|
||||
FUnexpectedSuccess:= FUnexpectedSuccess + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding;
|
||||
inc(FUnexpectedSuccessCnt);
|
||||
if FInTestBlock > 0 then begin
|
||||
FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding;
|
||||
if FInTestBlockRes in [tbOk] then
|
||||
FInTestBlockRes := tbUnexpected;
|
||||
end
|
||||
else begin
|
||||
FUnexpectedSuccess:= FUnexpectedSuccess + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding;
|
||||
inc(FUnexpectedSuccessCnt);
|
||||
end;
|
||||
end
|
||||
else
|
||||
inc(FSucessCnt);
|
||||
@ -257,12 +412,46 @@ begin
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.AssertTestErrors;
|
||||
|
||||
function RemoveHexNumbers(txt: String): String;
|
||||
var
|
||||
i, j, n: Integer;
|
||||
p, p2: SizeInt;
|
||||
s: String;
|
||||
begin
|
||||
Result := txt;
|
||||
i := 1;
|
||||
j := 1;
|
||||
n := 0;
|
||||
p := PosEx('$', Result, i);
|
||||
while p > 0 do begin
|
||||
if p > n then j := 1;
|
||||
n := PosSetEx([#10,#13], Result, p);
|
||||
i := p+2;
|
||||
|
||||
p2 := p + 2;
|
||||
while (p2 <= Length(Result)) and (Result[p2] in ['0'..'9', 'a'..'f', 'A'..'F']) do
|
||||
inc(p2);
|
||||
if p2 - p > 6 then begin
|
||||
s := copy(Result, p, p2-p);
|
||||
Result := StringReplace(Result, s, '$##HEX'+IntToStr(j)+'##', [rfReplaceAll, rfIgnoreCase]);
|
||||
inc(j);
|
||||
end;
|
||||
|
||||
p := PosEx('$', Result, i);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
s, s1: String;
|
||||
begin
|
||||
s := FTestErrors;
|
||||
s1 := Format('Failed: %d of %d - Ignored: %d Unexpected: %d - Success: %d',
|
||||
s1 := Format('Failed: %4d of %5d - Ignored: %5d Unexpected: %4d - Success: %5d',
|
||||
[FTestErrorCnt, FTestCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt ]);
|
||||
FDirectParent.AddOverviewLog(Format('%-30s %14s %12s %7s %18s %s',
|
||||
[TestName, Compiler.Name, SymbolTypeNames[Compiler.SymbolType],
|
||||
CpuBitNames[Compiler.CpuBitType], Debugger.Name,
|
||||
s1 + LineEnding]));
|
||||
FTestErrors := '';
|
||||
if GetLogActive or (FTestErrorCnt > 0) or (s <> '') then begin
|
||||
LogError('***' + s1 + '***' +LineEnding);
|
||||
@ -273,12 +462,27 @@ begin
|
||||
LogError('================= Unexpected Success'+LineEnding);
|
||||
LogError(FUnexpectedSuccess);
|
||||
LogError('================='+LineEnding);
|
||||
FIgnoredErrors := '';
|
||||
FUnexpectedSuccess := '';
|
||||
end;
|
||||
if s <> '' then begin
|
||||
if (TestControlGetWriteReport = wlAlways) or
|
||||
( (TestControlGetWriteReport = wlOnError) and (
|
||||
(FTestErrorCnt > 0) or (FIgnoredErrorCnt > 0) or (FUnexpectedSuccessCnt > 0)
|
||||
))
|
||||
then begin
|
||||
CreateReport;
|
||||
FReportFile.WriteLnToFile('***' + s1 + '***' +LineEnding);
|
||||
FReportFile.WriteLnToFile('================= Failed:'+LineEnding);
|
||||
FReportFile.WriteLnToFile(RemoveHexNumbers(s));
|
||||
FReportFile.WriteLnToFile('================= Ignored'+LineEnding);
|
||||
FReportFile.WriteLnToFile(RemoveHexNumbers(FIgnoredErrors));
|
||||
FReportFile.WriteLnToFile('================= Unexpected Success'+LineEnding);
|
||||
FReportFile.WriteLnToFile(RemoveHexNumbers(FUnexpectedSuccess));
|
||||
FReportFile.WriteLnToFile('================='+LineEnding);
|
||||
end;
|
||||
|
||||
FIgnoredErrors := '';
|
||||
FUnexpectedSuccess := '';
|
||||
if s <> '' then
|
||||
Fail(s1+ LineEnding + s);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDBGTestCase.TestMatches(Expected, Got: string; ACaseSense: Boolean
|
||||
@ -455,11 +659,11 @@ begin
|
||||
Result := FLogFileName;
|
||||
|
||||
if (FTotalIgnoredErrorCnt + FIgnoredErrorCnt > 0)
|
||||
then Result := Result + '.ignor_'+IntToStr(FTotalIgnoredErrorCnt + FIgnoredErrorCnt);
|
||||
then Result := Result + '___ignor.'+IntToStr(FTotalIgnoredErrorCnt + FIgnoredErrorCnt);
|
||||
if (FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt > 0)
|
||||
then Result := Result + '.unexp_'+IntToStr(FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt);
|
||||
then Result := Result + '___unexp.'+IntToStr(FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt);
|
||||
if (FTotalErrorCnt + FTestErrorCnt > 0)
|
||||
then Result := Result + '.fail_'+IntToStr(FTotalErrorCnt + FTestErrorCnt);
|
||||
then Result := Result + '___fail.'+IntToStr(FTotalErrorCnt + FTestErrorCnt);
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.InitLog;
|
||||
@ -509,6 +713,44 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.CreateReport;
|
||||
var
|
||||
name: String;
|
||||
i: Integer;
|
||||
dir: String;
|
||||
begin
|
||||
if FReportFileCreated then exit;
|
||||
EnterCriticalsection(FLogLock);
|
||||
try
|
||||
if FReportFileCreated then exit;
|
||||
|
||||
name := GetLogFileName;
|
||||
for i := 1 to length(name) do
|
||||
if name[i] in ['/', '\', '*', '?', ':'] then
|
||||
name[i] := '_';
|
||||
|
||||
if DirectoryExistsUTF8(TestControlGetLogPath) then
|
||||
dir := TestControlGetLogPath
|
||||
else
|
||||
dir := GetCurrentDirUTF8;
|
||||
|
||||
FReportFileName := dir + name;
|
||||
|
||||
{$IFDEF Windows}
|
||||
FReportFile := TLazLoggerFileHandleThreadSave.Create;
|
||||
{$ELSE}
|
||||
FReportFile := TLazLoggerFileHandleMainThread.Create;
|
||||
{$ENDIF}
|
||||
FReportFile.LogName := FReportFileName + '___fail.' + IntToStr(FTestErrorCnt) + '.report';
|
||||
//AssignFile(FReportFile, FReportFileName + '.log.running');
|
||||
//Rewrite(FReportFile);
|
||||
FReportFileCreated := True;
|
||||
|
||||
finally
|
||||
LeaveCriticalsection(FLogLock);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGTestCase.FinishLog;
|
||||
var
|
||||
NewName: String;
|
||||
@ -521,6 +763,12 @@ begin
|
||||
sleep(5);
|
||||
RenameFileUTF8(FLogFileName + '.log.running', NewName + '.log');
|
||||
end;
|
||||
if FReportFileCreated then begin
|
||||
CheckSynchronize(1);
|
||||
FreeAndNil(FReportFile);
|
||||
//CloseFile(FReportFile);
|
||||
FReportFileCreated := False;
|
||||
end;
|
||||
FLogBufferText.Clear;
|
||||
end;
|
||||
|
||||
@ -700,15 +948,9 @@ end;
|
||||
|
||||
{ TDBGTestsuite }
|
||||
|
||||
procedure TDBGTestsuite.Clear;
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
constructor TDBGTestsuite.Create(ACompiler: TTestDbgCompiler;
|
||||
ADebugger: TTestDbgDebugger);
|
||||
begin
|
||||
FInRun := False;
|
||||
FCompiler := ACompiler;
|
||||
FDebugger := ADebugger;
|
||||
inherited Create(ACompiler.FullName + ', ' + ADebugger.FullName);
|
||||
@ -722,48 +964,33 @@ begin
|
||||
AddTest(NewSuite);
|
||||
end;
|
||||
|
||||
procedure TDBGTestsuite.Run(AResult: TTestResult);
|
||||
begin
|
||||
FInRun := True;
|
||||
try
|
||||
inherited Run(AResult);
|
||||
finally
|
||||
FInRun := False;
|
||||
Clear;
|
||||
end;
|
||||
end;
|
||||
var
|
||||
MainTestSuite: TDbgBaseTestsuite;
|
||||
|
||||
procedure TDBGTestsuite.RunTest(ATest: TTest; AResult: TTestResult);
|
||||
begin
|
||||
try
|
||||
inherited RunTest(ATest, AResult);
|
||||
finally
|
||||
if not FInRun then Clear;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
|
||||
procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes);
|
||||
var
|
||||
Suite: TTestSuite;
|
||||
i: Integer;
|
||||
begin
|
||||
Suite := GetTestRegistry;
|
||||
//Suite := GetTestRegistry;
|
||||
Suite := MainTestSuite;
|
||||
for i := 0 to Suite.ChildTestCount - 1 do
|
||||
if Suite.Test[i] is TDBGTestsuite then
|
||||
TDBGTestsuite(Suite.Test[i]).RegisterDbgTest(ATestClass);
|
||||
if (ASymTypes = []) or (TDBGTestsuite(Suite.Test[i]).Compiler.SymbolType in ASymTypes) then
|
||||
TDBGTestsuite(Suite.Test[i]).RegisterDbgTest(ATestClass);
|
||||
end;
|
||||
|
||||
procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
|
||||
ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
|
||||
var
|
||||
i, j: Integer;
|
||||
r: TTestSuite;
|
||||
begin
|
||||
r := GetTestRegistry;
|
||||
MainTestSuite := TDbgBaseTestsuite.Create;
|
||||
GetTestRegistry.AddTest(MainTestSuite);
|
||||
for i := 0 to ACompilerList.Count - 1 do
|
||||
for j := 0 to ADebuggerList.Count - 1 do begin
|
||||
if ADebuggerList[j].MatchesCompiler(ACompilerList[i]) then begin
|
||||
r.AddTest(ATestSuiteClass.Create(ACompilerList[i], ADebuggerList[j]));
|
||||
MainTestSuite.AddTest(ATestSuiteClass.Create(ACompilerList[i], ADebuggerList[j]));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user