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

GdbmiDebugger, tests: breakpoints on raise/catch/... - Fix testcase

Browse Source 
git-svn-id: trunk@61647 -
This commit is contained in:
martin 2019-07-31 12:41:02 +00:00
parent daa6b60cf4
commit 93cd0df04f
2 changed files with 69 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -146,7 +146,9 @@ begin
{$ENDIF}
{$IFnDEF TEST_NO_EXCEPTION_TYPE}
try
foo;
except end;
{$ENDIF}
Freemem(GetMem(1));

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

@ -32,6 +32,9 @@ type
const AExceptionText: String;
out AContinue: Boolean);
protected
FInternalExceptionBrkSetMethod: TInternBrkSetMethod;
function GetLogFileName: String; override;
procedure DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
published
procedure TestException;
@ -39,6 +42,27 @@ type
procedure TestExceptionStepOver;
end;
{ TTestExceptionAddrDirect }
TTestExceptionAddrDirect = class(TTestExceptionOne)
public
constructor Create; override;
end;
{ TTestExceptionAddrInDirect }
TTestExceptionAddrInDirect = class(TTestExceptionOne)
public
constructor Create; override;
end;
{ TTestExceptionForceName }
TTestExceptionForceName = class(TTestExceptionOne)
public
constructor Create; override;
end;
const
(* Stepping out of the exception may currently stop one line before the "except statemet.
@ -64,6 +88,30 @@ implementation
var
ControlTestExceptionOne, ControlTestExceptionOneException, ControlTestExceptionOneExceptionStepOut, ControlTestExceptionOneExceptionStepOver: Pointer;
{ TTestExceptionForceName }
constructor TTestExceptionForceName.Create;
begin
FInternalExceptionBrkSetMethod := ibmName;
inherited Create;
end;
{ TTestExceptionAddrInDirect }
constructor TTestExceptionAddrInDirect.Create;
begin
FInternalExceptionBrkSetMethod := ibmAddrIndirect;
inherited Create;
end;
{ TTestExceptionAddrDirect }
constructor TTestExceptionAddrDirect.Create;
begin
FInternalExceptionBrkSetMethod := ibmAddrDirect;
inherited Create;
end;
//dbg.OnBreakPointHit := @DebuggerBreakPointHit;
//dbg.OnState := @DebuggerChangeState;
@ -84,6 +132,16 @@ begin
AContinue := FContinue;
end;
function TTestExceptionOne.GetLogFileName: String;
begin
Result := inherited GetLogFileName;
case FInternalExceptionBrkSetMethod of
ibmAddrIndirect: Result := StringReplace(Result, '_', '_AddrIndirect_', []);
ibmAddrDirect: Result := StringReplace(Result, '_', '_AddrDirect_', []);
ibmName: Result := StringReplace(Result, '_', '_Name_', []);
end;
end;
procedure TTestExceptionOne.DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
begin
FCurFile := ALocation.SrcFile;
@ -104,6 +162,7 @@ begin
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_raise_at', '-gt -dTEST_EXCEPTION_AT');
FGotExceptCount := 0;
dbg := StartGDB(AppDir, TestExeName);
TGDBMIDebuggerPropertiesBase(dbg.GetProperties).InternalExceptionBrkSetMethod := FInternalExceptionBrkSetMethod;
try
dbg.OnException := @DoDebuggerException;
@ -114,7 +173,7 @@ begin
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);
TestEquals(TstName+' Got location Line', 114, 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);
@ -343,12 +402,13 @@ begin
TestEquals(TstName+' Got msg', 'foo', FGotExceptMsg, 050300);
dbg.Run;
TestEquals(TstName+' Got 2nd exception', 2, FGotExceptCount);
dbg.Run;
TestEquals(TstName+' Got no more exception', 2, FGotExceptCount);
TestEquals(TstName+' Got class', 'MyESome', FGotExceptClass);
//TestEquals(TstName+' Got msg', 'abc üü {[''''[{ \n\t''#13#9''#', FGotExceptMsg, 050300);
TestEquals(TstName+' Got msg', 'abc üü {[''[{ \n\t'#13#9'#', FGotExceptMsg, 050300);
dbg.Run;
TestEquals(TstName+' Got no more exception', 2, FGotExceptCount);
dbg.Stop;
finally
dbg.Done;
@ -524,7 +584,10 @@ begin
end;
initialization
RegisterDbgTest(TTestExceptionOne);
RegisterDbgTest(TTestExceptionAddrDirect);
RegisterDbgTest(TTestExceptionAddrInDirect);
RegisterDbgTest(TTestExceptionForceName);
ControlTestExceptionOne := TestControlRegisterTest('TTestExceptionOne');
ControlTestExceptionOneException := TestControlRegisterTest('Exception', ControlTestExceptionOne);
ControlTestExceptionOneExceptionStepOut := TestControlRegisterTest('ExceptionStepOut', ControlTestExceptionOne);