paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-25 18:28:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

GdbmiDebugger, test: more output, to compare test results

Browse Source 
git-svn-id: trunk@64959 -
This commit is contained in:
martin 2021-04-10 23:48:07 +00:00
parent 05d6300123
commit caeb20c1c4
7 changed files with 512 additions and 251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas
View File

@ -321,13 +321,13 @@ begin
i := high(QWord) - FStartTime + 1 + i; i := high(QWord) - FStartTime + 1 + i;
if FTotalGDBInternalErrorCnt > 0 if FTotalGDBInternalErrorCnt > 0
then Result := Result + '.gdb_intern_'+IntToStr(FTotalGDBInternalErrorCnt); then Result := Result + '___gdb_intern.'+IntToStr(FTotalGDBInternalErrorCnt);
if FTotalDsErrorCrash > 0 if FTotalDsErrorCrash > 0
then Result := Result + '.gdb_crash_'+IntToStr(FTotalDsErrorCrash); then Result := Result + '___gdb_crash.'+IntToStr(FTotalDsErrorCrash);
if FTotalClassVsRecord > 0 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; end;
function TGDBTestCase.StartGDB(AppDir, TestExeName: String): TGDBMIDebugger; function TGDBTestCase.StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;

233
components/lazdebuggergdbmi/test/gdbmitestutils/testwatchutils.pas
View File

@ -407,125 +407,130 @@ var
end; end;
begin begin
if not TestTrue('Dbg did NOT enter dsError', ADbg.State <> dsError) then exit; StartTestBlock;
if Data.OnBeforeTest <> nil then Data.OnBeforeTest(@Data); try
if not TestTrue('Dbg did NOT enter dsError', ADbg.State <> dsError) then exit;
if Data.OnBeforeTest <> nil then Data.OnBeforeTest(@Data);
rx := nil; rx := nil;
Stack := Data.StackFrame; Stack := Data.StackFrame;
DataRes := Data.Result[SymbolType]; DataRes := Data.Result[SymbolType];
IgnoreFlags := DataRes.Flgs * WatchExpFlagMask[SymbolType]; IgnoreFlags := DataRes.Flgs * WatchExpFlagMask[SymbolType];
IgnoreAll := IgnoreFlags * WatchExpFlagSIgnAll <> []; IgnoreAll := IgnoreFlags * WatchExpFlagSIgnAll <> [];
IgnoreData := IgnoreFlags * WatchExpFlagSIgnData <> []; IgnoreData := IgnoreFlags * WatchExpFlagSIgnData <> [];
IgnoreKind := IgnoreFlags * WatchExpFlagSIgnKind <> []; IgnoreKind := IgnoreFlags * WatchExpFlagSIgnKind <> [];
IgnoreKindPtr := IgnoreFlags * WatchExpFlagSIgnKindPtr <> []; IgnoreKindPtr := IgnoreFlags * WatchExpFlagSIgnKindPtr <> [];
IgnoreTpName := IgnoreFlags * WatchExpFlagSIgnTpName <> []; IgnoreTpName := IgnoreFlags * WatchExpFlagSIgnTpName <> [];
// Get Value // Get Value
n := Data.TestName; n := Data.TestName;
if n = '' then n := Data.Expression + ' (' + TWatchDisplayFormatNames[Data.DspFormat] + ', ' + dbgs(Data.EvaluateFlags) + ' RepCnt=' + dbgs(Data.RepeatCount) + ')'; 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); Name := Name + ' ' + n + ' ::: '+adbg.GetLocation.SrcFile+' '+IntToStr(ADbg.GetLocation.SrcLine);
LogToFile('###### ' + Name + '###### '+LineEnding); LogToFile('###### ' + Name + '###### '+LineEnding);
flag := AWatch <> nil; // test for typeinfo/kind // Awatch=nil > direct gdb command flag := AWatch <> nil; // test for typeinfo/kind // Awatch=nil > direct gdb command
IsValid := True; IsValid := True;
HasTpInfo := True; HasTpInfo := True;
if flag then begin; if flag then begin;
WV := AWatch.Values[1, Stack];// trigger read WV := AWatch.Values[1, Stack];// trigger read
s := WV.Value; s := WV.Value;
IsValid := WV.Validity = ddsValid; IsValid := WV.Validity = ddsValid;
HasTpInfo := IsValid and (WV.TypeInfo <> nil); HasTpInfo := IsValid and (WV.TypeInfo <> nil);
// flag := flag and IsValid; // 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;
end end
else else
TestTrue(Name + ' no typeinfo for members' , False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText); s := WatchValue;
end;
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; end;
procedure TTestWatchesBase.AddWatches(ExpectList: TWatchExpectationArray; AWatches: TWatches; procedure TTestWatchesBase.AddWatches(ExpectList: TWatchExpectationArray; AWatches: TWatches;

4
components/lazdebuggergdbmi/test/testexception.pas
View File

@ -996,8 +996,8 @@ end;
initialization initialization
RegisterDbgTest(TTestExceptionAddrDirect); RegisterDbgTest(TTestExceptionAddrDirect);
RegisterDbgTest(TTestExceptionAddrInDirect); RegisterDbgTest(TTestExceptionAddrInDirect, [stDwarfSet, stStabs]);
RegisterDbgTest(TTestExceptionForceName); RegisterDbgTest(TTestExceptionForceName, [stDwarfSet, stStabs]);
ControlTestExceptionOne := TestControlRegisterTest('TTestExceptionOne'); ControlTestExceptionOne := TestControlRegisterTest('TTestExceptionOne');
ControlTestExceptionOneException := TestControlRegisterTest('Exception', ControlTestExceptionOne); ControlTestExceptionOneException := TestControlRegisterTest('Exception', ControlTestExceptionOne);

20
components/lazdebuggers/lazdebugtestbase/testdbgcontrol.pas
View File

@ -36,6 +36,8 @@ var
SetLogPathProc: TSetLogPath; SetLogPathProc: TSetLogPath;
GetLogPathProc: TGetLogPath; GetLogPathProc: TGetLogPath;
GetWriteLogProc: TGetWriteLog; GetWriteLogProc: TGetWriteLog;
GetWriteReportProc: TGetWriteLog;
GetWriteOverviewProc: TGetWriteLog;
RegisterCompilerProc: TRegisterCompiler; RegisterCompilerProc: TRegisterCompiler;
RegisterDebuggerProc: TRegisterDebugger; RegisterDebuggerProc: TRegisterDebugger;
RegisterTestProc: TRegisterTest; RegisterTestProc: TRegisterTest;
@ -54,6 +56,8 @@ function TestControlRegisterTest(Name: String; Parent: Pointer = nil): Pointer;
procedure TestControlSetLogPath(path: string); procedure TestControlSetLogPath(path: string);
function TestControlGetLogPath: string; function TestControlGetLogPath: string;
function TestControlGetWriteLog: TWriteLogConfig; function TestControlGetWriteLog: TWriteLogConfig;
function TestControlGetWriteReport: TWriteLogConfig;
function TestControlGetWriteOverView: TWriteLogConfig;
procedure TestControlRegisterCompilers(c: TBaseList); procedure TestControlRegisterCompilers(c: TBaseList);
procedure TestControlRegisterDebuggers(d: TBaseList); procedure TestControlRegisterDebuggers(d: TBaseList);
@ -151,6 +155,22 @@ begin
Result := wlAlways; Result := wlAlways;
end; 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); procedure TestControlRegisterCompilers(c: TBaseList);
var var
i: Integer; i: Integer;

99
components/lazdebuggers/lazdebugtestbase/testdbgcontrolform.lfm
View File

@ -77,6 +77,32 @@ object DbgTestControlForm: TDbgTestControlForm
MaxLength = 0 MaxLength = 0
TabOrder = 2 TabOrder = 2
end 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 end
object Panel2: TPanel object Panel2: TPanel
Left = 0 Left = 0
@ -265,74 +291,13 @@ object DbgTestControlForm: TDbgTestControlForm
end end
end end
object ilNodeStates: TImageList object ilNodeStates: TImageList
left = 220 Left = 220
top = 380 Top = 380
Bitmap = { Bitmap = {
4C69020000001000000010000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF 4C7A020000001000000010000000520000000000000078DAFBFF9F7CC0000450
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF 9A644C0BFD44BA7954FFA8FE41957E29C97F9482FFA3F99F28FD487A48D68FA6
FFFFFFFFFFFFFFFFFFFF00000000FFFFFFFF000000FF000000FF000000FF0000 07AF7E7473B0F899A07E7436B299C4EAC7A69758FFE3D24B4AF8E10ACFD1FC4F
00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 DDFC0F003436B484
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
} }
end end
end end

48
components/lazdebuggers/lazdebugtestbase/testdbgcontrolform.pas
View File

@ -16,6 +16,8 @@ type
{ TDbgTestControlForm } { TDbgTestControlForm }
TDbgTestControlForm = class(TForm) TDbgTestControlForm = class(TForm)
CheckWriteReport: TCheckBox;
CheckWriteOverview: TCheckBox;
chkDbg: TTreeView; chkDbg: TTreeView;
chkFpc: TTreeView; chkFpc: TTreeView;
chkSym: TCheckListBox; chkSym: TCheckListBox;
@ -51,11 +53,13 @@ type
procedure btnTestAllClick(Sender: TObject); procedure btnTestAllClick(Sender: TObject);
procedure btnTestNoneClick(Sender: TObject); procedure btnTestNoneClick(Sender: TObject);
procedure CheckWriteLogsChange(Sender: TObject); procedure CheckWriteLogsChange(Sender: TObject);
procedure CheckWriteOverviewChange(Sender: TObject);
procedure CheckWriteReportChange(Sender: TObject);
procedure chkTestsMouseDown(Sender: TObject; Button: TMouseButton; procedure chkTestsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
private private
FWriteLogValCache: TWriteLogConfig; FWriteLogValCache, FWriteReportValCache, FWriteOverViewValCache: TWriteLogConfig;
FWriteLogIsCached: Boolean; FWriteLogIsCached, FWriteReportIsCached, FWriteOverViewIsCached: Boolean;
public public
procedure DbgShow(Data: PtrInt); procedure DbgShow(Data: PtrInt);
end; end;
@ -163,6 +167,34 @@ begin
DbgTestControlForm.FWriteLogIsCached := True; DbgTestControlForm.FWriteLogIsCached := True;
end; 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); procedure RegisterCompiler(name: string);
begin begin
DbgTestControlForm.chkFpc.Items.Add(nil, Name) DbgTestControlForm.chkFpc.Items.Add(nil, Name)
@ -259,6 +291,16 @@ begin
FWriteLogIsCached := False; FWriteLogIsCached := False;
end; end;
procedure TDbgTestControlForm.CheckWriteOverviewChange(Sender: TObject);
begin
FWriteOverViewIsCached := False;
end;
procedure TDbgTestControlForm.CheckWriteReportChange(Sender: TObject);
begin
FWriteReportIsCached := False;
end;
procedure TDbgTestControlForm.DbgShow(Data: PtrInt); procedure TDbgTestControlForm.DbgShow(Data: PtrInt);
var var
s: TSymbolType; s: TSymbolType;
@ -293,6 +335,8 @@ initialization
SetLogPathProc := @SetLogPath; SetLogPathProc := @SetLogPath;
GetLogPathProc := @GetLogPath; GetLogPathProc := @GetLogPath;
GetWriteLogProc := @GetWriteLog; GetWriteLogProc := @GetWriteLog;
GetWriteReportProc := @GetWriteReport;
GetWriteOverviewProc := @GetWriteOverview;
RegisterCompilerProc := @RegisterCompiler; RegisterCompilerProc := @RegisterCompiler;
RegisterDebuggerProc := @RegisterDebugger; RegisterDebuggerProc := @RegisterDebugger;
RegisterTestProc := @RegisterTest; RegisterTestProc := @RegisterTest;

351
components/lazdebuggers/lazdebugtestbase/testdbgtestsuites.pas
View File

@ -7,7 +7,7 @@ interface
uses uses
Classes, SysUtils, TTestDbgExecuteables, TestDbgControl, TestDbgConfig, Classes, SysUtils, TTestDbgExecuteables, TestDbgControl, TestDbgConfig,
TestOutputLogger, TestCommonSources, LazFileUtils, LazLogger, TestOutputLogger, TestCommonSources, LazFileUtils, LazLogger,
DbgIntfDebuggerBase, fpcunit, testregistry, RegExpr; DbgIntfDebuggerBase, StrUtils, fpcunit, testregistry, RegExpr;
const const
EqIgnoreCase = False; // for TestEquals(..., CaseSense, ...); EqIgnoreCase = False; // for TestEquals(..., CaseSense, ...);
@ -17,23 +17,45 @@ type
TDBGTestsuite = class; TDBGTestsuite = class;
TDBGStates = set of TDBGState; 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 }
TDBGTestCase = class(TTestCase) TDBGTestCase = class(TTestCase)
private private
FParent: TDBGTestsuite; FParent: TDBGTestsuite;
FDirectParent: TDbgBaseTestsuite;
// TestResults // TestResults
FTestBaseName: String; FTestBaseName: String;
FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String; FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String;
FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer; FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer;
FInTestBlock: integer;
FInTestBlockTxt: String;
FInTestBlockRes: (tbOk, tbErr, tbIgnore, tbUnexpected);
FTotalErrorCnt, FTotalIgnoredErrorCnt, FTotalUnexpectedSuccessCnt: Integer; FTotalErrorCnt, FTotalIgnoredErrorCnt, FTotalUnexpectedSuccessCnt: Integer;
FRegX: TRegExpr; FRegX: TRegExpr;
// Logging // Logging
FLogLock: TRTLCriticalSection; FLogLock: TRTLCriticalSection;
FLogFile: TLazLoggerFileHandle; FLogFile, FReportFile: TLazLoggerFileHandle;
FLogFileCreated: Boolean; FLogFileCreated, FReportFileCreated: Boolean;
FLogFileName: String; FLogFileName, FReportFileName: String;
FLogBufferText: TStringList; FLogBufferText: TStringList;
procedure InitLog; procedure InitLog;
procedure FinishLog; procedure FinishLog;
@ -43,6 +65,8 @@ type
protected protected
FIgnoreReason: String; FIgnoreReason: String;
// TestResults // TestResults
procedure StartTestBlock;
procedure EndTestBlock;
procedure AddTestError (s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = ''); procedure AddTestError (s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
procedure AddTestError (s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = ''); procedure AddTestError (s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
procedure AddTestSuccess(s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = ''); procedure AddTestSuccess(s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
@ -56,6 +80,7 @@ type
function GetLogFileName: String; virtual; function GetLogFileName: String; virtual;
function GetFinalLogFileName: String; virtual; function GetFinalLogFileName: String; virtual;
procedure CreateLog; procedure CreateLog;
procedure CreateReport;
// Debugln // Debugln
procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); virtual; procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); virtual;
procedure DoDebugln(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 }
TDBGTestWrapper = class(TTestSuite) TDBGTestWrapper = class(TDbgBaseTestsuite)
private private
FParent: TDBGTestsuite; FParent: TDBGTestsuite;
public public
@ -127,18 +152,13 @@ type
{ TDBGTestsuite } { TDBGTestsuite }
TDBGTestsuite = class(TTestSuite) TDBGTestsuite = class(TDbgBaseTestsuite)
private private
FCompiler: TTestDbgCompiler; FCompiler: TTestDbgCompiler;
FDebugger: TTestDbgDebugger; FDebugger: TTestDbgDebugger;
FInRun: Boolean;
protected
procedure Clear; virtual;
public public
constructor Create(ACompiler: TTestDbgCompiler; ADebugger: TTestDbgDebugger); overload; constructor Create(ACompiler: TTestDbgCompiler; ADebugger: TTestDbgDebugger); overload;
procedure RegisterDbgTest(ATestClass: TTestCaseClass); procedure RegisterDbgTest(ATestClass: TTestCaseClass);
procedure Run(AResult: TTestResult); override;
procedure RunTest(ATest: TTest; AResult: TTestResult); override;
property Compiler: TTestDbgCompiler read FCompiler; property Compiler: TTestDbgCompiler read FCompiler;
property Debugger: TTestDbgDebugger read FDebugger; property Debugger: TTestDbgDebugger read FDebugger;
@ -146,13 +166,93 @@ type
TDBGTestsuiteClass = class of TDBGTestsuite; TDBGTestsuiteClass = class of TDBGTestsuite;
procedure RegisterDbgTest(ATestClass: TTestCaseClass); procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes = []);
procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList; procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass); ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
implementation 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 } { TDBGTestCase }
function TDBGTestCase.GetCompiler: TTestDbgCompiler; function TDBGTestCase.GetCompiler: TTestDbgCompiler;
@ -165,6 +265,39 @@ begin
Result := Parent.Debugger; Result := Parent.Debugger;
end; 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; procedure TDBGTestCase.AddTestError(s: string; MinDbgVers: Integer;
AIgnoreReason: String); AIgnoreReason: String);
begin begin
@ -177,7 +310,8 @@ var
IgnoreReason: String; IgnoreReason: String;
i: Integer; i: Integer;
begin begin
inc(FTestCnt); if FInTestBlock = 0 then
inc(FTestCnt);
IgnoreReason := ''; IgnoreReason := '';
s := FTestBaseName + s; s := FTestBaseName + s;
if MinDbgVers > 0 then begin if MinDbgVers > 0 then begin
@ -194,13 +328,26 @@ begin
if IgnoreReason = '' then if IgnoreReason = '' then
IgnoreReason := FIgnoreReason; IgnoreReason := FIgnoreReason;
if IgnoreReason <> '' then begin if FInTestBlock > 0 then begin
FIgnoredErrors := FIgnoredErrors + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding; if IgnoreReason <> '' then begin
inc(FIgnoredErrorCnt); FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
end else begin if FInTestBlockRes in [tbOk, tbUnexpected] then
FTestErrors := FTestErrors + IntToStr(FTestCnt) + ': ' + s + LineEnding; FInTestBlockRes := tbIgnore;
DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]); end else begin
inc(FTestErrorCnt); 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;
end; end;
@ -216,7 +363,8 @@ var
i: Integer; i: Integer;
begin begin
s := FTestBaseName + s; s := FTestBaseName + s;
inc(FTestCnt); if FInTestBlock = 0 then
inc(FTestCnt);
if (MinDbgVers > 0) then begin if (MinDbgVers > 0) then begin
i := Debugger.Version; i := Debugger.Version;
if (i > 0) and (i < MinDbgVers) then if (i > 0) and (i < MinDbgVers) then
@ -232,8 +380,15 @@ begin
if AIgnoreReason <> '' then begin if AIgnoreReason <> '' then begin
s := '[OK] ' + s; s := '[OK] ' + s;
FUnexpectedSuccess:= FUnexpectedSuccess + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding; if FInTestBlock > 0 then begin
inc(FUnexpectedSuccessCnt); 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 end
else else
inc(FSucessCnt); inc(FSucessCnt);
@ -257,12 +412,46 @@ begin
end; end;
procedure TDBGTestCase.AssertTestErrors; 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 var
s, s1: String; s, s1: String;
begin begin
s := FTestErrors; 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 ]); [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 := ''; FTestErrors := '';
if GetLogActive or (FTestErrorCnt > 0) or (s <> '') then begin if GetLogActive or (FTestErrorCnt > 0) or (s <> '') then begin
LogError('***' + s1 + '***' +LineEnding); LogError('***' + s1 + '***' +LineEnding);
@ -273,12 +462,27 @@ begin
LogError('================= Unexpected Success'+LineEnding); LogError('================= Unexpected Success'+LineEnding);
LogError(FUnexpectedSuccess); LogError(FUnexpectedSuccess);
LogError('================='+LineEnding); LogError('================='+LineEnding);
FIgnoredErrors := '';
FUnexpectedSuccess := '';
end; 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); Fail(s1+ LineEnding + s);
end;
end; end;
function TDBGTestCase.TestMatches(Expected, Got: string; ACaseSense: Boolean function TDBGTestCase.TestMatches(Expected, Got: string; ACaseSense: Boolean
@ -455,11 +659,11 @@ begin
Result := FLogFileName; Result := FLogFileName;
if (FTotalIgnoredErrorCnt + FIgnoredErrorCnt > 0) if (FTotalIgnoredErrorCnt + FIgnoredErrorCnt > 0)
then Result := Result + '.ignor_'+IntToStr(FTotalIgnoredErrorCnt + FIgnoredErrorCnt); then Result := Result + '___ignor.'+IntToStr(FTotalIgnoredErrorCnt + FIgnoredErrorCnt);
if (FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt > 0) if (FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt > 0)
then Result := Result + '.unexp_'+IntToStr(FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt); then Result := Result + '___unexp.'+IntToStr(FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt);
if (FTotalErrorCnt + FTestErrorCnt > 0) if (FTotalErrorCnt + FTestErrorCnt > 0)
then Result := Result + '.fail_'+IntToStr(FTotalErrorCnt + FTestErrorCnt); then Result := Result + '___fail.'+IntToStr(FTotalErrorCnt + FTestErrorCnt);
end; end;
procedure TDBGTestCase.InitLog; procedure TDBGTestCase.InitLog;
@ -509,6 +713,44 @@ begin
end; end;
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; procedure TDBGTestCase.FinishLog;
var var
NewName: String; NewName: String;
@ -521,6 +763,12 @@ begin
sleep(5); sleep(5);
RenameFileUTF8(FLogFileName + '.log.running', NewName + '.log'); RenameFileUTF8(FLogFileName + '.log.running', NewName + '.log');
end; end;
if FReportFileCreated then begin
CheckSynchronize(1);
FreeAndNil(FReportFile);
//CloseFile(FReportFile);
FReportFileCreated := False;
end;
FLogBufferText.Clear; FLogBufferText.Clear;
end; end;
@ -700,15 +948,9 @@ end;
{ TDBGTestsuite } { TDBGTestsuite }
procedure TDBGTestsuite.Clear;
begin
//
end;
constructor TDBGTestsuite.Create(ACompiler: TTestDbgCompiler; constructor TDBGTestsuite.Create(ACompiler: TTestDbgCompiler;
ADebugger: TTestDbgDebugger); ADebugger: TTestDbgDebugger);
begin begin
FInRun := False;
FCompiler := ACompiler; FCompiler := ACompiler;
FDebugger := ADebugger; FDebugger := ADebugger;
inherited Create(ACompiler.FullName + ', ' + ADebugger.FullName); inherited Create(ACompiler.FullName + ', ' + ADebugger.FullName);
@ -722,48 +964,33 @@ begin
AddTest(NewSuite); AddTest(NewSuite);
end; end;
procedure TDBGTestsuite.Run(AResult: TTestResult); var
begin MainTestSuite: TDbgBaseTestsuite;
FInRun := True;
try
inherited Run(AResult);
finally
FInRun := False;
Clear;
end;
end;
procedure TDBGTestsuite.RunTest(ATest: TTest; AResult: TTestResult); procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes);
begin
try
inherited RunTest(ATest, AResult);
finally
if not FInRun then Clear;
end;
end;
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
var var
Suite: TTestSuite; Suite: TTestSuite;
i: Integer; i: Integer;
begin begin
Suite := GetTestRegistry; //Suite := GetTestRegistry;
Suite := MainTestSuite;
for i := 0 to Suite.ChildTestCount - 1 do for i := 0 to Suite.ChildTestCount - 1 do
if Suite.Test[i] is TDBGTestsuite then 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; end;
procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList; procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass); ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
var var
i, j: Integer; i, j: Integer;
r: TTestSuite;
begin begin
r := GetTestRegistry; MainTestSuite := TDbgBaseTestsuite.Create;
GetTestRegistry.AddTest(MainTestSuite);
for i := 0 to ACompilerList.Count - 1 do for i := 0 to ACompilerList.Count - 1 do
for j := 0 to ADebuggerList.Count - 1 do begin for j := 0 to ADebuggerList.Count - 1 do begin
if ADebuggerList[j].MatchesCompiler(ACompilerList[i]) then 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; end;
end; end;