paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-04 09:39:43 +01:00
Code Issues Packages Projects Releases Wiki Activity

GDBMI debugger: more tests for LineInfo with exceptions, run error, assert

Browse Source 
git-svn-id: trunk@56243 -
This commit is contained in:
martin 2017-10-30 00:25:45 +00:00
parent efb8df15a1
commit a43dd15a73
5 changed files with 220 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
components/lazdebuggergdbmi/test/TestApps/ExceptPrg.pas
View File

@ -1,4 +1,4 @@
program ExceptPrg;
program ExceptPrg; {$INLINE OFF}
{$IFDEF TEST_WITH_HPLUS}
{$H+}
{$ELSE}
@ -35,12 +35,78 @@ var
end;
{$ENDIF}
{$IFDEF TEST_EXCEPTION_AT}
procedure Bar;
begin
raise Exception.create('at1') at
get_caller_addr(get_caller_frame(get_frame)),
get_caller_frame(get_caller_frame(get_frame));
end;
procedure Bar1;
begin
Bar();
end;
procedure Bar2;
begin
Bar1();
end;
procedure BarBar;
begin
raise Exception.create('at2') at
get_caller_addr(get_frame),
get_caller_frame(get_frame);
end;
procedure BarBar1;
begin
BarBar();
end;
procedure BarBar2;
begin
BarBar1();
end;
{$ENDIF}
{$IFDEF TEST_RUNERR}
{$R+}
procedure Run;
var a: array of integer;
begin
SetLength(a, 2);
a[0] := -2;
a[1] := a[length(a)-a[0]];
end;
procedure Run1;
begin
Run();
end;
{$ENDIF}
{$IFDEF TEST_ASSERT}
{$C+}
procedure check;
begin
Assert(false, 'denied');
end;
procedure check1;
begin
check();
end;
{$ENDIF}
begin
{$IFnDEF TEST_NO_POINTER_VAR}
p := nil;
{$ENDIF}
//foo;
{$IFnDEF TEST_SKIP_EXCEPTION_1}
try
{$IFnDEF TEST_NO_EXCEPTION_VAR}
x := Exception.Create('foo');
@ -59,8 +125,28 @@ begin
end;
end;
writeln(1);
{$ENDIF}
{$IFDEF TEST_EXCEPTION_AT}
try
Bar2();
except end;
try
BarBar2();
except end;
{$ENDIF}
{$IFDEF TEST_RUNERR}
Run1();
{$ENDIF}
{$IFDEF TEST_ASSERT}
check1();
{$ENDIF}
{$IFnDEF TEST_NO_EXCEPTION_TYPE}
foo;
{$ENDIF}
writeln(2);
end.

13
components/lazdebuggergdbmi/test/TestGdbmi.lpi
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
@ -12,9 +12,6 @@
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
@ -53,7 +50,6 @@
<Unit0>
<Filename Value="TestGdbmi.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TestGdbmi"/>
</Unit0>
<Unit1>
<Filename Value="testexception.pas"/>
@ -124,6 +120,9 @@
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<Optimizations>
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
@ -132,11 +131,7 @@
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CustomOptions Value="-gt"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>

15
components/lazdebuggergdbmi/test/gdbmitestutils/gdbmitestutils.lpk
View File

@ -3,6 +3,7 @@
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="GdbmiTestUtils"/>
<Type Value="RunAndDesignTime"/>
<Author Value="M Friebe"/>
<CompilerOptions>
<Version Value="11"/>
@ -10,12 +11,11 @@
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
</Linking>
</CompilerOptions>
<Description Value="Test helper units for LazDebuggerGDBMI"/>
<License Value="GPL2"/>
@ -39,10 +39,9 @@
</Item4>
<Item5>
<Filename Value="testwatchutils.pas"/>
<UnitName Value="testwatchutils"/>
<UnitName Value="TestWatchUtils"/>
</Item5>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="FPCUnitTestRunner"/>

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

@ -6,7 +6,8 @@ interface
uses
Classes, SysUtils, FileUtil, fpcunit, testutils, testregistry, LCLProc, LazLogger,
LazFileUtils, DbgIntfDebuggerBase, CompileHelpers, Dialogs, TestGDBMIControl, GDBMIDebugger; // , FpGdbmiDebugger;
LazFileUtils, DbgIntfDebuggerBase, CompileHelpers, Dialogs, TestGDBMIControl,
RegExpr, GDBMIDebugger; // , FpGdbmiDebugger;
// EnvironmentOpts, ExtToolDialog, TransferMacros,
(*
@ -375,6 +376,10 @@ type
procedure AddTestSuccess(s: string; MinGdbVers: Integer = 0; AIgnoreReason: String = '');
procedure AddTestSuccess(s: string; MinGdbVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
function TestMatches(Expected, Got: string): Boolean;
function TestMatches(Name: string; Expected, Got: string; MinGdbVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
function TestMatches(Name: string; Expected, Got: string; MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
function TestEquals(Expected, Got: string): Boolean;
function TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
function TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
@ -1066,6 +1071,32 @@ begin
inc(FSucessCnt);
end;
function TGDBTestCase.TestMatches(Expected, Got: string): Boolean;
begin
Result := TestMatches('', Expected, Got);
end;
function TGDBTestCase.TestMatches(Name: string; Expected, Got: string;
MinGdbVers: Integer; AIgnoreReason: String): Boolean;
begin
Result := TestMatches(Name, Expected, Got, MinGdbVers, 0, AIgnoreReason);
end;
function TGDBTestCase.TestMatches(Name: string; Expected, Got: string;
MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
var
rx: TRegExpr;
begin
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Expected;
Result := rx.Exec(Got);
FreeAndNil(rx);
if Result
then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "'+Got+'"', MinGdbVers, MinFpcVers, AIgnoreReason)
else AddTestError(Name + ': Expected "'+Expected+'", Got "'+Got+'"', MinGdbVers, MinFpcVers, AIgnoreReason);
end;
function TGDBTestCase.TestEquals(Expected, Got: string): Boolean;
begin
Result := TestEquals('', Expected, Got);

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

@ -21,6 +21,7 @@ type
FGotExceptClass: String;
FGotExceptMsg: String;
FGotExceptType: TDBGExceptionType;
FGotExceptionLocation: TDBGLocationRec;
procedure DoDebuggerException(Sender: TObject;
const AExceptionType: TDBGExceptionType;
@ -61,6 +62,7 @@ begin
FGotExceptClass := AExceptionClass;
FGotExceptMsg := AExceptionText;
FGotExceptType := AExceptionType;
FGotExceptionLocation := AExceptionLocation;
AContinue := False;
end;
@ -77,26 +79,106 @@ var
begin
if SkipTest then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf(' TTestException')] then exit;
ClearTestErrors;
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '', '-gt -gh');
TstName := 'All';
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_raise_at', '-gt -gh -dTEST_EXCEPTION_AT');
try
FGotExceptCount := 0; TstName := 'all';
FGotExceptCount := 0;
dbg := StartGDB(AppDir, TestExeName);
dbg.OnException := @DoDebuggerException;
dbg.Run;
TestEquals(TstName+' Got 1 exception', 1, FGotExceptCount);
TstName := 'All - raise';
TestEquals(TstName+' Got 1 exception', 1, FGotExceptCount);
TestEquals(TstName+' Got class', 'Exception', FGotExceptClass);
TestEquals(TstName+' Got msg', 'foo', FGotExceptMsg, 060000);
TestEquals(TstName+' Got location Line', 113, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
TestMatches(TstName+' Got location Proc', '^main$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deInternal);
dbg.Run;
TstName := 'All - raise at 2 down';
TestEquals(TstName+' Got exception 2', 2, FGotExceptCount);
TestEquals(TstName+' Got class', 'Exception', FGotExceptClass);
TestEquals(TstName+' Got msg', 'foo', FGotExceptMsg, 060000);
TestEquals(TstName+' Got msg', 'at1', FGotExceptMsg, 060000);
TestEquals(TstName+' Got location Line', 53, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
TestMatches(TstName+' Got location Proc', '^Bar2$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deInternal);
dbg.Run;
TestEquals(TstName+' Got 2nd exception', 2, FGotExceptCount);
TstName := 'All - raise at 1 down';
TestEquals(TstName+' Got exception 3', 3, FGotExceptCount);
TestEquals(TstName+' Got class', 'Exception', FGotExceptClass);
TestEquals(TstName+' Got msg', 'at2', FGotExceptMsg, 060000);
TestEquals(TstName+' Got location Line', 65, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
TestMatches(TstName+' Got location Proc', '^BarBar1$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deInternal);
dbg.Run;
TestEquals(TstName+' Got no more exception', 2, FGotExceptCount);
TstName := 'All - raise subclass';
TestEquals(TstName+'Got exception 4', 4, FGotExceptCount);
TestEquals(TstName+' Got class', 'MyESome', FGotExceptClass);
// not yet MakePrintable
//TestEquals(TstName+' Got msg', 'abc üü {[''''[{ \n\t''#13#9''#', FGotExceptMsg, 050300);
TestEquals(TstName+' Got msg', 'abc üü {[''[{ \n\t'#13#9'#', FGotExceptMsg, 050300);
TestEquals(TstName+' Got location Line', 34, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
TestMatches(TstName+' Got location Proc', '^foo$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deInternal);
dbg.Run;
TestEquals(TstName+' Got no more exception', 4, FGotExceptCount);
dbg.Stop;
finally
dbg.Done;
CleanGdb;
dbg.Free;
end;
TstName := 'RunError';
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_runerr', '-gt -gh -dTEST_SKIP_EXCEPTION_1 -dTEST_RUNERR');
try
FGotExceptCount := 0;
dbg := StartGDB(AppDir, TestExeName);
dbg.OnException := @DoDebuggerException;
dbg.Run;
TestEquals(TstName+' Got run err', 1, FGotExceptCount);
TestMatches(TstName+' Got class', 'RunError', FGotExceptClass);
//TestEquals(TstName+' Got msg', 'at2', FGotExceptMsg, 060000);
TestEquals(TstName+' Got location Line', 81, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
TestMatches(TstName+' Got location Proc', '^Run$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deRunError);
dbg.Stop;
finally
dbg.Done;
CleanGdb;
dbg.Free;
end;
TstName := 'Assert';
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_assert', '-gt -gh -dTEST_SKIP_EXCEPTION_1 -dTEST_ASSERT');
try
FGotExceptCount := 0;
dbg := StartGDB(AppDir, TestExeName);
dbg.OnException := @DoDebuggerException;
dbg.Run;
TestEquals(TstName+' Got Assert', 1, FGotExceptCount);
TestMatches(TstName+' Got class', 'EAssertionFailed', FGotExceptClass);
TestMatches(TstName+' Got msg', 'denied', FGotExceptMsg, 060000);
// TestEquals(TstName+' Got location Line', 94, FGotExceptionLocation.SrcLine);
TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
// TestMatches(TstName+' Got location Proc', '^check$', FGotExceptionLocation.FuncName);
TestTrue(TstName+' Got type', FGotExceptType = deInternal);
dbg.Stop;
finally
dbg.Done;
@ -243,6 +325,7 @@ var
begin
if SkipTest then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf(' TTestExceptionStepOut')] then exit;
ClearTestErrors;
TestCompile(AppDir + 'ExceptPrgStep.pas', TestExeName, '', '');
@ -289,7 +372,7 @@ end;
initialization
RegisterDbgTest(TTestExceptionOne);
RegisterTestSelectors(['TTestExceptionOne'
RegisterTestSelectors(['TTestExceptionOne', ' TTestException', ' TTestExceptionStepOut'
]);
end.