paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-05 22:57:15 +01:00
Code Issues Packages Projects Releases Wiki Activity

DBG: Test

Browse Source 
git-svn-id: trunk@32198 -
This commit is contained in:
martin 2011-09-06 22:55:21 +00:00
parent 13f01cf37b
commit 1c525dd53a
7 changed files with 704 additions and 328 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2789,6 +2789,7 @@ debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc svneol=native#text/pascal
debugger/test/Gdbmi/TestApps/WatchesPrgString.inc svneol=native#text/pascal
debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc svneol=native#text/pascal
debugger/test/Gdbmi/TestApps/WatchesPrgVariant.inc svneol=native#text/pascal
debugger/test/Gdbmi/TestApps/u1/unitw1.pas svneol=native#text/pascal
debugger/test/Gdbmi/TestGdbmi.lpi svneol=native#text/pascal
debugger/test/Gdbmi/TestGdbmi.lpr svneol=native#text/pascal
debugger/test/Gdbmi/compilehelpers.pas svneol=native#text/pascal

74
debugger/test/Gdbmi/TestApps/WatchesPrg.pas
View File

@ -1,7 +1,12 @@
// Do not add/remove lines
// TestWatches.pas expects hardcoded lines for breakpoints
(* Struture
program WatchesPrg;
type
{$DEFINE Global_Types}
{$DEFINE Global_Implementation}
procedure FooFunc( {$DEFINE FooFunc_Param} }
@ -9,13 +14,23 @@
{$DEFINE FooFunc_LocalType}
var
{$DEFINE FooFunc_Local}
function SubFoo()():Integer; begin end;
function SubFoo()():Integer;
type
{$DEFINE SubFooFunc_LocalType}
var
{$DEFINE SubFooFunc_Local}
begin
{$DEFINE SubFooFunc_Body}
end;
begin
{$DEFINE FooFunc_Body}
end;
var
{$DEFINE Global_Var}
begin
{$DEFINE Global_Body}
FooFunc( {$DEFINE Global_Call_FooFunc} );
@ -28,7 +43,7 @@
program WatchesPrg;
{$H-}
uses sysutils, variants, Classes;
uses sysutils, variants, Classes {$IFDEF USE_W1} , unitw1 {$ENDIF};
type
{$DEFINE Global_Types}
@ -132,7 +147,62 @@ var
{$UNDEF FooFunc_Local}
function SubFoo(var AVal1: Integer; AVal2: Integer) : Integer;
type
(*** local type ***)
{$DEFINE SubFooFunc_LocalType}
{ class/record/object }
{$I WatchesPrgStruct.inc}
{ strings }
{$I WatchesPrgString.inc}
{ simple }
{$I WatchesPrgSimple.inc}
{ enum/set }
{$I WatchesPrgEnum.inc}
{ Array }
{$I WatchesPrgArray.inc}
{ variants }
{$I WatchesPrgVariant.inc}
{ procedure/function/method }
{$I WatchesPrgProc.inc}
DummySubFooType12345 = Integer;
{$UNDEF SubFooFunc_LocalType}
var
(*** local var ***)
{$DEFINE SubFooFunc_Local}
{ class/record/object }
{$I WatchesPrgStruct.inc}
{ strings }
{$I WatchesPrgString.inc}
{ simple }
{$I WatchesPrgSimple.inc}
{ enum/set }
{$I WatchesPrgEnum.inc}
{ Array }
{$I WatchesPrgArray.inc}
{ variants }
{$I WatchesPrgVariant.inc}
{ procedure/function/method }
{$I WatchesPrgProc.inc}
DummySubFooVar12345: Integer;
{$UNDEF SubFooFunc_Local}
begin
{$DEFINE SubFooFunc_Body}
{ class/record/object }
{$I WatchesPrgStruct.inc}
{ strings }
{$I WatchesPrgString.inc}
{ simple }
{$I WatchesPrgSimple.inc}
{ enum/set }
{$I WatchesPrgEnum.inc}
{ Array }
{$I WatchesPrgArray.inc}
{ variants }
{$I WatchesPrgVariant.inc}
{ procedure/function/method }
{$I WatchesPrgProc.inc}
{$UNDEF SubFooFunc_Body}
writeln(1); // nested break
end;

50
debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc
View File

@ -1,4 +1,54 @@
{* ******************** CACHE-TEST ******************** *}
{%region CACHE-TEST}
{%region TYPE}
{$IFDEF Global_Types}
TCacheTestType = class
public
CTVal: Integer;
end;
{$ENDIF}
{$IFDEF SubFooFunc_LocalType}
TCacheTest = record
CTVal: Integer;
end;
{$ENDIF}
{$IFDEF FooFunc_LocalType}
TCacheTest = TCacheTestType;
{$ENDIF}
{%endregion TYPE}
{%region VARIABLES}
{$IFDEF SubFooFunc_Local}
VarCacheTest1: TCacheTest; // record
VarCacheTest2: Integer;
{$ENDIF}
{$IFDEF FooFunc_Local}
VarCacheTest1: TCacheTest; // class
VarCacheTest2: Integer;
{$ENDIF}
{%endregion VARIABLES}
{%region CODE (initilization)}
{$IFDEF SubFooFunc_Body}
VarCacheTest1.CTVal := 101;
VarCacheTest2 := 102;
{$ENDIF}
{$IFDEF FooFunc_Body}
VarCacheTest1 := TCacheTest.Create;
VarCacheTest1.CTVal := 201;
VarCacheTest2 := 202;
{$ENDIF}
{%endregion CODE (initilization)}
{%endregion CACHE-TEST}
{* ******************** -- ******************** *}
{%region FooFunc}
{$IFDEF FooFunc_Param}
//procedure FooFunc(

290
debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc
View File

@ -33,6 +33,7 @@
{$ENDIF}
{* ******************** RECORD ******************** *}
{%region RECORD}
{%region TYPE}
@ -174,7 +175,171 @@
{%endregion RECORD}
{* ******************** CLASSES ******************** *}
{%region CLASSES}
{%region TYPE}
{$IFDEF Global_Types}
//type
{ Classes }
TFooComp = class(TComponent)
public
ValueInt: Integer;
end;
{$IFDEF USE_W1}
TFooCompOtherBase = class(TFooTestTestBase)
{$ELSE}
TFooCompOtherBase = class(TObject)
{$ENDIF}
public
ValueInt: Integer;
end;
{ TFoo }
TFoo = class
private
function GetValueInt: Integer;
procedure SetValueInt(AValue: Integer);
public
ValueInt: Integer;
ValueFoo: TFoo;
ValueRec: TRec;
FooText: string[20];
FooString: String;
FooChar: Char;
property PropInt: Integer read ValueInt write ValueInt;
property PropIntGS: Integer read GetValueInt write SetValueInt;
end;
TFooChild = class(TFoo) end;
TFooKid = class(TFoo) end;
PFoo = ^TFoo;
PPFoo = ^PFoo;
TSamePFoo = PFoo;
TNewPFoo = {type} PFoo; // fpc crash
TSameFoo = TFoo;
TNewFoo = type TFoo;
PNewFoo = ^TNewFoo;
{$ENDIF}
{$IFDEF FooFunc_LocalType}
//type
{$ENDIF}
{%endregion TYPE}
{%region VARIABLES}
{$IFDEF FooFunc_Param}
{$ENDIF}
{$IFDEF Global_Call_FooFunc}
//FooFunc(
{ Classes }
GlobTFoo, GlobTFoo,
GlobPFoo, GlobPFoo,
GlobPPFoo, GlobPPFoo,
GlobTSamePFoo, GlobTSamePFoo,
GlobTNewPFoo, GlobTNewPFoo,
GlobTSameFoo, GlobTSameFoo,
GlobTNewFoo, GlobTNewFoo,
GlobPNewFoo, GlobPNewFoo,
{$ENDIF}
{$IFDEF FooFunc_Local}
//var
{$ENDIF}
{$IFDEF Global_Var}
//var
{ Classes }
GlobTFoo, GlobTFoo1, GlobTFoo2, GlobTFooNil: TFoo;
GlobPFoo: PFoo;
GlobPPFoo: PPFoo;
GlobTSamePFoo: TSamePFoo;
GlobTNewPFoo: TNewPFoo;
GlobTSameFoo: TSameFoo;
GlobTNewFoo: TNewFoo;
GlobPNewFoo: PNewFoo;
PGlobTFoo: ^TFoo;
PGlobPFoo: ^PFoo;
PGlobTSamePFoo: ^TSamePFoo;
PGlobTSameFoo: ^TSameFoo;
{$ENDIF}
{$IFDEF Global_Implementation}
{ TFoo }
function TFoo.GetValueInt: Integer;
begin
Result := PropInt;
end;
procedure TFoo.SetValueInt(AValue: Integer);
begin
PropInt := AValue;
end;
{$ENDIF}
{%endregion VARIABLES}
{%region CODE (initilization)}
{$IFDEF FooFunc_Body}
//begin
{$ENDIF}
{$IFDEF Global_Body}
//begin
{ Classes }
GlobTFoo := TFoo.Create;
GlobTFoo.ValueInt := -11;
GlobTFoo.FooText := 'mem of TFoo '' "';
GlobTFoo.FooString := 'a 1 \ " '' '#9'...';
GlobTFoo.FooChar := '\';
GlobTFoo1 := TFoo.Create;
GlobTFoo1.ValueInt := 31;
GlobTFoo2 := TFoo.Create;
GlobTFoo2.ValueInt := 32;
GlobTFooNil := nil;
GlobPFoo := @GlobTFoo1;
GlobPPFoo := @GlobPFoo;
GlobTSamePFoo := @GlobTFoo2;
GlobTNewPFoo := @GlobTFoo;
GlobTSameFoo := TFoo.Create;
GlobTSameFoo.ValueInt := 41;
GlobTNewFoo := TNewFoo.Create;
GlobTNewFoo.ValueInt := 42;
GlobPNewFoo := @GlobTSameFoo;
PGlobTFoo := @GlobTFoo;
PGlobPFoo := @PGlobTFoo;
PGlobTSamePFoo := @GlobTFoo;
PGlobTSameFoo := @GlobTFoo;
{$ENDIF}
{$IFDEF Global_Body_NIL}
//begin
{ Classes }
GlobTFoo := nil;
GlobPFoo := nil;
GlobPPFoo := nil;
GlobTSamePFoo := nil;
GlobTNewPFoo := nil;
GlobTSameFoo := nil;
GlobTNewFoo := nil;
GlobPNewFoo := nil;
{$ENDIF}
{%endregion CODE (initilization)}
{%endregion CLASSES}
{* ******************** CLASSTYPES ******************** *}
{%region FooFunc}
{$IFDEF FooFunc_Param}
@ -225,7 +390,8 @@
PVarTFooClass: ^TFooClass;
VarFooComp, VarFooComp1: TFooComp;
VarFooComp, VarFooComp1: TObject; // TFooComp;
VarFooOther, VarFooOther1: TObject; // TFooCompOtherBase;
{ OBJECT }
VarOldObject: TOldObject;
@ -262,48 +428,16 @@
VarOldObject.OldVal := 1;
VarFooComp := TFooComp.Create(nil);
VarFooComp := nil;
VarFooComp1 := nil;
VarFooOther := TFooCompOtherBase.Create;
VarFooOther1 := nil;
{$ENDIF}
{%endregion FooFunc}
{%region GLOBAL}
{$IFDEF Global_Types}
{ Classes }
TFooComp = class(TComponent)
public
ValueInt: Integer;
end;
{ TFoo }
TFoo = class
private
function GetValueInt: Integer;
procedure SetValueInt(AValue: Integer);
public
ValueInt: Integer;
ValueFoo: TFoo;
ValueRec: TRec;
FooText: string[20];
FooString: String;
FooChar: Char;
property PropInt: Integer read ValueInt write ValueInt;
property PropIntGS: Integer read GetValueInt write SetValueInt;
end;
TFooChild = class(TFoo) end;
TFooKid = class(TFoo) end;
PFoo = ^TFoo;
PPFoo = ^PFoo;
TSamePFoo = PFoo;
TNewPFoo = {type} PFoo; // fpc crash
TSameFoo = TFoo;
TNewFoo = type TFoo;
PNewFoo = ^TNewFoo;
{ ClassesTypes }
TFooClass = Class of TFoo;
PFooClass = ^TFooClass;
@ -319,37 +453,6 @@
{$ENDIF}
{$IFDEF Global_Var}
{ TFoo }
function TFoo.GetValueInt: Integer;
begin
Result := PropInt;
end;
procedure TFoo.SetValueInt(AValue: Integer);
begin
PropInt := AValue;
end;
var
//var
{ Classes }
GlobTFoo, GlobTFoo1, GlobTFoo2, GlobTFooNil: TFoo;
GlobPFoo: PFoo;
GlobPPFoo: PPFoo;
GlobTSamePFoo: TSamePFoo;
GlobTNewPFoo: TNewPFoo;
GlobTSameFoo: TSameFoo;
GlobTNewFoo: TNewFoo;
GlobPNewFoo: PNewFoo;
PGlobTFoo: ^TFoo;
PGlobPFoo: ^PFoo;
PGlobTSamePFoo: ^TSamePFoo;
PGlobTSameFoo: ^TSameFoo;
{ ClassesTyps }
GlobTFooClass: TFooClass;
GlobPFooClass: PFooClass;
@ -362,33 +465,6 @@
{$IFDEF Global_Body}
//begin
{ Classes }
GlobTFoo := TFoo.Create;
GlobTFoo.ValueInt := -11;
GlobTFoo.FooText := 'mem of TFoo '' "';
GlobTFoo.FooString := 'a 1 \ " '' '#9'...';
GlobTFoo.FooChar := '\';
GlobTFoo1 := TFoo.Create;
GlobTFoo1.ValueInt := 31;
GlobTFoo2 := TFoo.Create;
GlobTFoo2.ValueInt := 32;
GlobTFooNil := nil;
GlobPFoo := @GlobTFoo1;
GlobPPFoo := @GlobPFoo;
GlobTSamePFoo := @GlobTFoo2;
GlobTNewPFoo := @GlobTFoo;
GlobTSameFoo := TFoo.Create;
GlobTSameFoo.ValueInt := 41;
GlobTNewFoo := TNewFoo.Create;
GlobTNewFoo.ValueInt := 42;
GlobPNewFoo := @GlobTSameFoo;
PGlobTFoo := @GlobTFoo;
PGlobPFoo := @PGlobTFoo;
PGlobTSamePFoo := @GlobTFoo;
PGlobTSameFoo := @GlobTFoo;
{ ClassesTyps }
GlobTFooClass := TFooKid;
GlobPFooClass := @GlobTFooClass;
@ -401,17 +477,6 @@
{$IFDEF Global_Body_NIL}
//begin
{ Classes }
GlobTFoo := nil;
GlobPFoo := nil;
GlobPPFoo := nil;
GlobTSamePFoo := nil;
GlobTNewPFoo := nil;
GlobTSameFoo := nil;
GlobTNewFoo := nil;
GlobPNewFoo := nil;
{ ClassesTyps }
GlobTFooClass := nil;
GlobPFooClass := nil;
@ -422,17 +487,6 @@
{$IFDEF Global_Call_FooFunc}
//FooFunc(
{ Classes }
GlobTFoo, GlobTFoo,
GlobPFoo, GlobPFoo,
GlobPPFoo, GlobPPFoo,
GlobTSamePFoo, GlobTSamePFoo,
GlobTNewPFoo, GlobTNewPFoo,
GlobTSameFoo, GlobTSameFoo,
GlobTNewFoo, GlobTNewFoo,
GlobPNewFoo, GlobPNewFoo,
{ ClassesTyps }
GlobTFooClass, GlobTFooClass,
GlobPFooClass, GlobPFooClass,

14
debugger/test/Gdbmi/TestApps/u1/unitw1.pas Normal file
View File

@ -0,0 +1,14 @@
unit unitw1;
{$mode objfpc}{$H+}
interface
type
TFooTestTestBase = class
a: integer;
end;
implementation
end.

118
debugger/test/Gdbmi/testbase.pas
View File

@ -51,7 +51,7 @@ type
end;
TUsesDir = record
DirName: String;
DirName, ExeId: String; // dirname = filename
SymbolType: TSymbolType;
ExtraOpts, NamePostFix: string;
end;
@ -117,7 +117,7 @@ type
FSymbolSwitch: String;
FSymbolType: TSymbolType;
FFileNameExt: String;
FCompiledList: TStringList;
FCompiledList, FCompiledUsesList, FCompiledUsesListID: TStringList;
FInRun: Boolean;
protected
procedure Clear;
@ -127,7 +127,7 @@ type
procedure Run(AResult: TTestResult); override;
procedure RunTest(ATest: TTest; AResult: TTestResult); override;
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
Procedure TestCompileUses(UsesDir: TUsesDir; out UsesLibDir);
procedure TestCompileUses(UsesDir: TUsesDir; out UsesLibDir: String; out ExeID:string);
Procedure TestCompile(const PrgName: string;
out ExeName: string;
NamePostFix: String=''; ExtraArgs: String=''
@ -154,7 +154,7 @@ type
public
constructor Create(AParent: TCompilerSuite; ADebuggerInfo: TDebuggerInfo);
procedure RegisterDbgTest(ATestClass: TTestCaseClass);
Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String='');
Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String='');
public
property Parent: TCompilerSuite read FParent;
property DebuggerInfo: TDebuggerInfo read FDebuggerInfo;
@ -173,7 +173,7 @@ type
public
constructor Create(AParent: TDebuggerSuite; AClass: TClass);
procedure AddTest(ATest: TTest); overload; override;
Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String='');
Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String='');
public
property Parent: TDebuggerSuite read FParent;
property DebuggerInfo: TDebuggerInfo read GetDebuggerInfo;
@ -202,6 +202,7 @@ type
FRegisters: TIDERegisters;
private
FParent: TGDBTestsuite;
FTestBaseName: String;
FTestResult: TGDBTestResult;
FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String;
FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer;
@ -232,12 +233,15 @@ type
procedure AssertTestErrors;
property TestErrors: string read FTestErrors;
public
Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String='');
Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); overload;
Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir;
NamePostFix: String=''; ExtraArgs: String=''); overload;
public
property Parent: TGDBTestsuite read FParent write FParent;
property DebuggerInfo: TDebuggerInfo read GetDebuggerInfo;
property SymbolType: TSymbolType read GetSymbolType;
property CompilerInfo: TCompilerInfo read GetCompilerInfo;
property TestBaseName: String read FTestBaseName write FTestBaseName;
public
//property BreakPoints: TIDEBreakPoints read FBreakpoints; // A list of breakpoints for the current project
//property BreakPointGroups: TIDEBreakPointGroups read FBreakPointGroups;
@ -290,6 +294,21 @@ begin
end;
end;
function NameToFileName(AName: String): String;
var
i: Integer;
begin
Result := '';
for i := 1 to length(AName) do begin
if AName[i] in ['a'..'z', 'A'..'Z', '0'..'9', '.', '-'] then
Result := Result + AName[i]
else if AName[i] = ' ' then
Result := Result + '__'
else
Result := Result + '_' + IntToHex(ord(AName[i]), 2);
end;
end;
function GetCompilers: TCompilerList;
begin
@ -371,9 +390,9 @@ var
begin
if GetLogActive then begin
name := TestName
+ '_' + GetCompilerInfo.Name
+ '_' + NameToFileName(GetCompilerInfo.Name)
+ '_' + SymbolTypeNames[GetSymbolType]
+ '_' + GetDebuggerInfo.Name
+ '_' + NameToFileName(GetDebuggerInfo.Name)
+ '.log';
dir := ConfDir;
if DirectoryExistsUTF8(Logdir) then
@ -470,6 +489,7 @@ begin
FUnexpectedSuccessCnt := 0;
FSucessCnt := 0;
FTestCnt := 0;
FTestBaseName := '';
end;
procedure TGDBTestCase.AddTestError(s: string; MinGdbVers: Integer = 0);
@ -479,6 +499,7 @@ var
begin
inc(FTestCnt);
IgnoreReason := '';
s := FTestBaseName + s;
if MinGdbVers > 0 then begin
i := GetDebuggerInfo.Version;
if (i > 0) and (i < MinGdbVers) then
@ -497,6 +518,7 @@ procedure TGDBTestCase.AddTestSuccess(s: string; MinGdbVers: Integer);
var
i: Integer;
begin
s := FTestBaseName + s;
inc(FTestCnt);
if MinGdbVers > 0 then begin
i := GetDebuggerInfo.Version;
@ -577,11 +599,17 @@ end;
procedure TGDBTestCase.TestCompile(const PrgName: string; out ExeName: string;
NamePostFix: String=''; ExtraArgs: String='');
begin
TestCompile(PrgName, ExeName, [], NamePostFix, ExtraArgs);
end;
procedure TGDBTestCase.TestCompile(const PrgName: string; out ExeName: string;
UsesDirs: array of TUsesDir; NamePostFix: String; ExtraArgs: String);
begin
if GetLogActive then begin
writeln(FLogFile, LineEnding+LineEnding+'******************* compile '+PrgName + ' ' + ExtraArgs +LineEnding);
end;
Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs);
Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs);
FCurrentPrgName := PrgName;
FCurrentExename := ExeName;
end;
@ -739,7 +767,11 @@ var
begin
for i := 0 to FCompiledList.Count - 1 do
DeleteFile(FCompiledList[i]);
for i := 0 to FCompiledUsesList.Count - 1 do
DeleteDirectory(FCompiledUsesList[i], False);
FCompiledList.Clear;
FCompiledUsesList.Clear;
FCompiledUsesListID.Clear;
end;
constructor TCompilerSuite.Create(ACompilerInfo: TCompilerInfo; ASymbolType: TSymbolType;
@ -753,18 +785,12 @@ begin
FSymbolType := ASymbolType;
FCompiledList := TStringList.Create;
FCompiledUsesList := TStringList.Create;
FCompiledUsesListID := TStringList.Create;
FSymbolSwitch := SymbolTypeSwitches[FSymbolType];
FInRun := False;
FFileNameExt := SymbolTypeNames[FSymbolType] + '_';
for i := 1 to length(CompilerInfo.Name) do begin
if CompilerInfo.Name[i] in ['a'..'z', 'A'..'Z', '0'..'9', '.', '-'] then
FFileNameExt := FFileNameExt + CompilerInfo.Name[i]
else if CompilerInfo.Name[i] = ' ' then
FFileNameExt := FFileNameExt + '__'
else
FFileNameExt := FFileNameExt + '_' + IntToHex(ord(CompilerInfo.Name[i]), 2);
end;
FFileNameExt := SymbolTypeNames[FSymbolType] + '_' + NameToFileName(CompilerInfo.Name);
for i := 0 to ADebuggerList.Count - 1 do begin
if not (FSymbolType in ADebuggerList.SymbolTypes[i]) then
@ -779,6 +805,8 @@ begin
inherited Destroy;
Clear;
FreeAndNil(FCompiledList);
FreeAndNil(FCompiledUsesList);
FreeAndNil(FCompiledUsesListID);
end;
procedure TCompilerSuite.Run(AResult: TTestResult);
@ -810,9 +838,36 @@ begin
TDebuggerSuite(Test[i]).RegisterDbgTest(ATestClass);
end;
procedure TCompilerSuite.TestCompileUses(UsesDir: TUsesDir; out UsesLibDir);
procedure TCompilerSuite.TestCompileUses(UsesDir: TUsesDir; out UsesLibDir: String; out ExeID:string);
var
Opts: String;
i: Integer;
DirPostFix: String;
begin
DirPostFix := SymbolTypeNames[UsesDir.SymbolType] + '_' + NameToFileName(CompilerInfo.Name);
UsesLibDir := AppendPathDelim(ExtractFilePath(UsesDir.DirName)) + 'lib__'
+ DirPostFix;
if UsesDir.NamePostFix <> '' then
UsesLibDir := UsesLibDir + '__' + UsesDir.NamePostFix;
i := FCompiledUsesList.IndexOf(UsesLibDir);
if i < 0 then begin
if DirectoryExists(AppendPathDelim(UsesLibDir)) then
raise EAssertionFailedError.Create('Found existing dir before compiling: ' + UsesLibDir);
i := FCompiledUsesList.Add(UsesLibDir);
ExeID := '_U'+IntToStr(i)+UsesDir.ExeId+'_'+DirPostFix+'__';
FCompiledUsesListID.Add(ExeID);
CreateDirUTF8(UsesLibDir);
Opts := SymbolTypeSwitches[UsesDir.SymbolType] + ' ' + UsesDir.ExtraOpts;
if not CompileHelper.TestCompileUnits(CompilerInfo.ExeName, Opts, UsesDir.DirName, UsesLibDir)
then
raise EAssertionFailedError.Create('Compilation Failed: ' + UsesDir.DirName + LineEnding + CompileHelper.LastError);
end
else begin
ExeID := FCompiledUsesListID[i];
end;
end;
procedure TCompilerSuite.TestCompile(const PrgName: string; out ExeName: string;
@ -824,13 +879,23 @@ end;
procedure TCompilerSuite.TestCompile(const PrgName: string; out ExeName: string;
UsesDirs: array of TUsesDir; NamePostFix: String; ExtraArgs: String);
var
ExePath, ErrMsg: String;
ExePath, ErrMsg, ExtraFUPath: String;
i: Integer;
NewLibDir, NewExeID: string;
begin
ExePath := ExtractFileNameWithoutExt(PrgName);
ExeName := ExtractFileNameOnly(ExePath);
ExePath := AppendPathDelim(copy(ExePath, 1, length(ExePath) - length(ExeName)));
if DirectoryExistsUTF8(ExePath + 'lib') then
ExePath := AppendPathDelim(ExePath + 'lib');
ExtraFUPath := '';
for i := low(UsesDirs) to high(UsesDirs) do begin
TestCompileUses(UsesDirs[i], NewLibDir, NewExeID);
ExtraFUPath := ExtraFUPath + ' -Fu'+NewLibDir;
NamePostFix := NamePostFix + NewExeID;
end;
ExeName := ExePath + ExeName + FFileNameExt + NamePostFix + GetExeExt;
if ExtraArgs <> '' then
@ -839,7 +904,10 @@ begin
if FileExists(ExeName) then
raise EAssertionFailedError.Create('Found existing file before compiling: ' + ExeName);
FCompiledList.Add(ExeName);
ErrMsg := CompileHelper.TestCompile(PrgName, FSymbolSwitch + ' ' + FCompilerInfo.ExtraOpts + ExtraArgs, ExeName, CompilerInfo.ExeName);
ErrMsg := CompileHelper.TestCompile(PrgName,
FSymbolSwitch + ' ' + ExtraFUPath + ' ' + FCompilerInfo.ExtraOpts + ExtraArgs,
ExeName,
CompilerInfo.ExeName);
if ErrMsg <> '' then begin
debugln(ErrMsg);
raise EAssertionFailedError.Create('Compilation Failed: ' + ExeName + LineEnding + ErrMsg);
@ -879,9 +947,9 @@ begin
end;
procedure TDebuggerSuite.TestCompile(const PrgName: string; out ExeName: string;
NamePostFix: String=''; ExtraArgs: String='');
UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String='');
begin
Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs);
Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs);
end;
{ TGDBTestsuite }
@ -915,9 +983,9 @@ begin
end;
procedure TGDBTestsuite.TestCompile(const PrgName: string; out ExeName: string;
NamePostFix: String=''; ExtraArgs: String='');
UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String='');
begin
Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs);
Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs);
end;
{ --- }

459
debugger/test/Gdbmi/testwatches.pas
View File

@ -9,8 +9,8 @@ uses
TestBase, Debugger, GDBMIDebugger, LCLProc, SynRegExpr, Forms, StdCtrls, Controls;
const
BREAK_LINE_FOOFUNC = 160;
BREAK_LINE_FOOFUNC_NEST = 136;
BREAK_LINE_FOOFUNC = 230;
BREAK_LINE_FOOFUNC_NEST = 206;
RUN_GDB_TEST_ONLY = -1; // -1 run all
RUN_TEST_ONLY = -1; // -1 run all
@ -26,33 +26,7 @@ const
*)
type
{ TTestWatches }
TTestWatches = class(TGDBTestCase)
private
FWatches: TcurrentWatches;
FDbgOutPut: String;
FDbgOutPutEnable: Boolean;
procedure DoDbgOutput(Sender: TObject; const AText: String); override;
public
procedure DebugInteract(dbg: TGDBMIDebugger);
published
procedure TestWatches;
end;
implementation
var
DbgForm: TForm;
DbgMemo: TMemo;
DbgLog: Boolean;
const
RNoPreQuote = '(^|[^''])'; // No open qoute (Either at start, or other char)
RNoPostQuote = '($|[^''])'; // No close qoute (Either at end, or other char)
type
TWatchExpectationFlag =
(fnoDwrf, // no dwarf at all
fnoDwrfNoSet, // no dwarf2 (-gw) without set
@ -62,23 +36,61 @@ type
fTpMtch
);
TWatchExpectationFlags = set of TWatchExpectationFlag;
TWatchExpectation = record
Exp: string;
Fmt: TWatchDisplayFormat;
Mtch: string;
Kind: TDBGSymbolKind;
TpNm: string;
TWatchExpectation = record
Expression: string;
DspFormat: TWatchDisplayFormat;
StackFrame: Integer;
ExpMatch: string;
ExpKind: TDBGSymbolKind;
ExpTypeName: string;
Flgs: TWatchExpectationFlags;
end;
TWatchExpectationArray = array of TWatchExpectation;
var
// direct commands to gdb, to check assumptions // only Exp and Mtch
ExpectGdbBrk1NoneNil: Array of TWatchExpectation;
// Watches
ExpectBrk1NoneNil: Array of TWatchExpectation;
{ TTestWatches }
TTestWatches = class(TGDBTestCase)
private
FWatches: TcurrentWatches;
ExpectBreakFooGdb: TWatchExpectationArray; // direct commands to gdb, to check assumptions // only Exp and Mtch
ExpectBreakSubFoo: TWatchExpectationArray; // Watches, evaluated in SubFoo (nested)
ExpectBreakFoo: TWatchExpectationArray; // Watches, evaluated in Foo
FDbgOutPut: String;
FDbgOutPutEnable: Boolean;
procedure DoDbgOutput(Sender: TObject; const AText: String); override;
procedure ClearAllTestArrays;
procedure AddTo(var ExpArray: TWatchExpectationArray;
AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string;
AFlgs: TWatchExpectationFlags = [];
AStackFrame: Integer = 0
);
procedure AddExpectBreakFooGdb;
procedure AddExpectBreakFooAll;
procedure AddExpectBreakFooMixInfo;
//procedure AddExpectBreakSubFoo;
procedure AddExpectBreakFooAndSubFoo; // check for caching issues
procedure RunTestWatches(NamePreFix: String;
TestExeName, ExtraOpts: String;
UsedUnits: array of TUsesDir
);
public
procedure DebugInteract(dbg: TGDBMIDebugger);
published
procedure TestWatches;
end;
implementation
const
RNoPreQuote = '(^|[^''])'; // No open qoute (Either at start, or other char)
RNoPostQuote = '($|[^''])'; // No close qoute (Either at end, or other char)
Match_Pointer = '\$[0-9A-F]+';
M_Int = 'Integer|LongInt';
@ -89,52 +101,13 @@ const
{%ebdregion * Classes * }
// Todo: Dwarf fails with dereferenced var pointer types
procedure InitializeExpectGdbBrk1NoneNil;
procedure Add(AnExp: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags
);
begin
SetLength(ExpectGdbBrk1NoneNil, Length(ExpectGdbBrk1NoneNil)+1);
with ExpectGdbBrk1NoneNil[Length(ExpectGdbBrk1NoneNil)-1] do begin
Exp := AnExp;
Fmt := AFmt;
Mtch := AMtch;
Kind := AKind;
TpNm := ATpNm;
Flgs := AFlgs;
end;
end;
begin
Add('ptype ArgTFoo', wdfDefault, 'type = \^TFoo = class : PUBLIC TObject', skClass, '', []);
Add('ptype ArgTFoo^', wdfDefault, 'type = TFoo = class : PUBLIC TObject', skClass, '', []);
Add('-data-evaluate-expression sizeof(ArgTFoo)', wdfDefault, 'value="(4|8)"|(parse|syntax) error in expression', skClass, '', []);
Add('-data-evaluate-expression sizeof(ArgTFoo^)', wdfDefault, 'value="\d\d+"|(parse|syntax) error in expression', skClass, '', []);
end;
procedure InitializeExpectBrk1NoneNil;
procedure Add(AnExp: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string;
AFlgs: TWatchExpectationFlags = []
);
begin
SetLength(ExpectBrk1NoneNil, Length(ExpectBrk1NoneNil)+1);
with ExpectBrk1NoneNil[Length(ExpectBrk1NoneNil)-1] do begin
Exp := AnExp;
Fmt := AFmt;
Mtch := AMtch;
Kind := AKind;
TpNm := ATpNm;
Flgs := AFlgs;
end;
end;
function MatchPointer(TypeName: String=''): String;
begin
if TypeName = ''
then Result := '\$[0-9A-F]+'
else Result := TypeName+'\(\$[0-9A-F]+';
end;
function MatchRecord(TypeName: String; AContent: String = ''): String;
begin
Result := 'record '+TypeName+' .+'+AContent;
@ -144,6 +117,57 @@ procedure InitializeExpectBrk1NoneNil;
Result := 'record '+TypeName+' .+ valint = '+IntToStr(AValInt);
If AValFoo <> '' then Result := Result + ',.* valfoo = '+AValFoo;
end;
{ TTestWatches }
procedure TTestWatches.ClearAllTestArrays;
begin
SetLength(ExpectBreakFooGdb, 0);
SetLength(ExpectBreakSubFoo, 0);
SetLength(ExpectBreakFoo, Length(ExpectBreakFoo)+1);
end;
procedure TTestWatches.AddTo(var ExpArray: TWatchExpectationArray; AnExpr: string;
AFmt: TWatchDisplayFormat; AMtch: string; AKind: TDBGSymbolKind; ATpNm: string;
AFlgs: TWatchExpectationFlags; AStackFrame: Integer = 0);
begin
SetLength(ExpArray, Length(ExpArray)+1);
with ExpArray[Length(ExpArray)-1] do begin
Expression := AnExpr;
DspFormat := AFmt;
ExpMatch := AMtch;
ExpKind := AKind;
ExpTypeName := ATpNm;
Flgs := AFlgs;
StackFrame := AStackFrame;
end;
end;
procedure TTestWatches.AddExpectBreakFooGdb;
procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags);
begin
AddTo(ExpectBreakFooGdb,AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs )
end;
begin
Add('ptype ArgTFoo', wdfDefault, 'type = \^TFoo = class : PUBLIC TObject', skClass, '', []);
Add('ptype ArgTFoo^', wdfDefault, 'type = TFoo = class : PUBLIC TObject', skClass, '', []);
Add('-data-evaluate-expression sizeof(ArgTFoo)', wdfDefault, 'value="(4|8)"|(parse|syntax) error in expression', skClass, '', []);
Add('-data-evaluate-expression sizeof(ArgTFoo^)', wdfDefault, 'value="\d\d+"|(parse|syntax) error in expression', skClass, '', []);
if RUN_GDB_TEST_ONLY > 0 then begin
ExpectBreakFooGdb[0] := ExpectBreakFooGdb[abs(RUN_GDB_TEST_ONLY)];
SetLength(ExpectBreakFooGdb, 1);
end;
end;
procedure TTestWatches.AddExpectBreakFooAll;
procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags);
begin
AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs )
end;
begin
{%region * records * }
// Foo(var XXX: PRecord); DWARF has problems with the implicit pointer for "var"
@ -294,6 +318,7 @@ begin
//Add('ArgTFoo=nil', wdfDefault, 'False', skSimple, 'bool', []);
//Add('not(ArgTFoo=nil)', wdfDefault, 'True', skSimple, 'bool', []);
//Add('ArgTFoo<>nil', wdfDefault, 'True', skSimple, 'bool', []);
{%endregion * Classes * }
{%region * Strings * }
@ -510,17 +535,55 @@ begin
*)
{%endregion * procedure/function/method * }
if RUN_TEST_ONLY > 0 then begin
ExpectBreakFoo[0] := ExpectBreakFoo[abs(RUN_TEST_ONLY)];
SetLength(ExpectBreakFoo, 1);
end;
end;
{ TTestWatches }
procedure TTestWatches.AddExpectBreakFooMixInfo;
procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags);
begin
AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs )
end;
begin
// MIXED symbol info types
Add('VarFooOther', wdfDefault, '<TObject>', skClass, 'TObject', []);
Add('TFooTestTestBase(VarFooOther)', wdfDefault, '<TFooTestTestBase>', skClass, 'TFooTestTestBase', []);
Add('VarStatIntArray', wdfDefault, '10,[\s\r\n]+12,[\s\r\n]+14,[\s\r\n]+16,[\s\r\n]+18',
skSimple, 'TStatIntArray',
[]);
end;
procedure TTestWatches.AddExpectBreakFooAndSubFoo;
procedure AddF(AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags;
AStackFrame: Integer=0);
begin
AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs, AStackFrame)
end;
procedure AddS(AnExpr: string; AFmt: TWatchDisplayFormat;
AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags;
AStackFrame: Integer=0);
begin
AddTo(ExpectBreakSubFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs, AStackFrame)
end;
begin
AddS('VarCacheTest1', wdfDefault, MatchRecord('TCacheTest', 'CTVal = 101'),
skRecord, 'TCacheTest', []);
AddF('VarCacheTest1', wdfDefault, '<TCacheTest(Type)?> = \{.*(<|vptr\$)TObject>?.+CTVal = 201',
skClass, 'TCacheTest(Type)?', [fTpMtch]);
AddS('VarCacheTest2', wdfDefault, '102', skSimple, M_Int, [fTpMtch], 0);
AddS('VarCacheTest2', wdfDefault, '202', skSimple, M_Int, [fTpMtch], 1);
end;
procedure TTestWatches.DoDbgOutput(Sender: TObject; const AText: String);
begin
inherited DoDbgOutput(Sender, AText);
if FDbgOutPutEnable then
FDbgOutPut := FDbgOutPut + AText;
if DbgLog and (DbgMemo <> nil) then
DbgMemo.Lines.Add(AText);
end;
procedure TTestWatches.DebugInteract(dbg: TGDBMIDebugger);
@ -533,7 +596,9 @@ begin
end;
end;
procedure TTestWatches.TestWatches;
procedure TTestWatches.RunTestWatches(NamePreFix: String; TestExeName, ExtraOpts: String;
UsedUnits: array of TUsesDir);
function SkipTest(const Data: TWatchExpectation): Boolean;
begin
@ -556,13 +621,15 @@ procedure TTestWatches.TestWatches;
s: String;
flag: Boolean;
WV: TWatchValue;
Stack: Integer;
begin
rx := nil;
Stack := Data.StackFrame;
Name := Name + ' ' + Data.Exp + ' (' + TWatchDisplayFormatNames[Data.Fmt] + ')';
Name := Name + ' ' + Data.Expression + ' (' + TWatchDisplayFormatNames[Data.DspFormat] + ')';
flag := AWatch <> nil;
if flag then begin;
WV := AWatch.Values[1, 0];// trigger read
WV := AWatch.Values[1, Stack];// trigger read
s := WV.Value;
flag := flag and TestTrue (Name+ ' (HasValue)', WV.Validity = ddsValid);
//flag := flag and TestFalse (Name+ ' (One Value)', AWatch.HasMultiValue);
@ -573,14 +640,14 @@ procedure TTestWatches.TestWatches;
if flag then begin
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Data.Mtch;
if Data.Mtch <> ''
then TestTrue(Name + ' Matches "'+Data.Mtch + '", but was "' + s + '"', rx.Exec(s));
rx.Expression := Data.ExpMatch;
if Data.ExpMatch <> ''
then TestTrue(Name + ' Matches "'+Data.ExpMatch + '", but was "' + s + '"', rx.Exec(s));
end;
flag := (AWatch <> nil) and (Data.TpNm <> '');
flag := (AWatch <> nil) and (Data.ExpTypeName <> '');
if flag then flag := TestTrue(Name + ' has typeinfo', WV.TypeInfo <> nil);
if flag then flag := TestEquals(Name + ' kind', KindName[Data.Kind], KindName[WV.TypeInfo.Kind]);
if flag then flag := TestEquals(Name + ' kind', KindName[Data.ExpKind], KindName[WV.TypeInfo.Kind]);
if flag then begin
if fTpMtch in Data.Flgs
then begin
@ -588,138 +655,190 @@ procedure TTestWatches.TestWatches;
s := WV.TypeInfo.TypeName;
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Data.TpNm;
TestTrue(Name + ' TypeName matches '+Data.TpNm+' but was '+WV.TypeInfo.TypeName, rx.Exec(s))
rx.Expression := Data.ExpTypeName;
TestTrue(Name + ' TypeName matches '+Data.ExpTypeName+' but was '+WV.TypeInfo.TypeName, rx.Exec(s))
end
else TestEquals(Name + ' TypeName', LowerCase(Data.TpNm), LowerCase(WV.TypeInfo.TypeName));
else TestEquals(Name + ' TypeName', LowerCase(Data.ExpTypeName), LowerCase(WV.TypeInfo.TypeName));
end;
FreeAndNil(rx);
end;
var
TestExeName: string;
dbg: TGDBMIDebugger;
i: Integer;
WList: Array of TCurrentWatch;
begin
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestWatch')] then exit;
WList, WListSub: Array of TCurrentWatch;
begin
TestBaseName := NamePreFix;
ClearTestErrors;
try
TestCompile(AppDir + 'WatchesPrg.pas', TestExeName);
TestCompile(AppDir + 'WatchesPrg.pas', TestExeName, UsedUnits, '', ExtraOpts);
except
on e: Exception do Fail('Compile error: ' + e.Message);
on e: Exception do begin
TestTrue('Compile error: ' + e.Message, False);
exit;
end;
end;
try
dbg := StartGDB(AppDir, TestExeName);
FWatches := Watches.CurrentWatches;
if (RUN_TEST_ONLY >= 0) or (RUN_GDB_TEST_ONLY >= 0) then begin
DbgLog := False;
if DbgForm = nil then begin
DbgForm := TForm.Create(Application);
DbgMemo := TMemo.Create(DbgForm);
DbgMemo.Parent := DbgForm;
DbgMemo.Align := alClient;
DbgForm.Show;
end;
DbgMemo.Lines.Add('');
DbgMemo.Lines.Add(' *** ' + Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + TestSuiteName+' '+TestName);
DbgMemo.Lines.Add('');
end;
(* Add breakpoints *)
//with dbg.BreakPoints.Add('WatchesPrg.pas', 44) do begin
// InitialEnabled := True;
// Enabled := True;
//end;
with dbg.BreakPoints.Add('WatchesPrg.pas', BREAK_LINE_FOOFUNC) do begin
InitialEnabled := True;
Enabled := True;
end;
(* Create all watches *)
SetLength(WList, high(ExpectBrk1NoneNil)+1);
if RUN_TEST_ONLY >= 0 then begin
i := RUN_TEST_ONLY;
WList[i] := TCurrentWatch.Create(FWatches);
WList[i].Expression := ExpectBrk1NoneNil[i].Exp;
WList[i].DisplayFormat := ExpectBrk1NoneNil[i].Fmt;
WList[i].enabled := True;
end
else
for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do begin
if not SkipTest(ExpectBrk1NoneNil[i]) then begin
WList[i] := TCurrentWatch.Create(FWatches);
WList[i].Expression := ExpectBrk1NoneNil[i].Exp;
WList[i].DisplayFormat := ExpectBrk1NoneNil[i].Fmt;
WList[i].enabled := True;
end;
with dbg.BreakPoints.Add('WatchesPrg.pas', BREAK_LINE_FOOFUNC_NEST) do begin
InitialEnabled := True;
Enabled := True;
end;
(* Start debugging *)
if dbg.State = dsError then
Fail(' Failed Init');
dbg.ShowConsole := True;
(* Create all watches *)
SetLength(WList, length(ExpectBreakFoo));
for i := low(ExpectBreakFoo) to high(ExpectBreakFoo) do begin
if not SkipTest(ExpectBreakFoo[i]) then begin
WList[i] := TCurrentWatch.Create(FWatches);
WList[i].Expression := ExpectBreakFoo[i].Expression;
WList[i].DisplayFormat := ExpectBreakFoo[i].DspFormat;
WList[i].enabled := True;
end;
end;
SetLength(WListSub, length(ExpectBreakSubFoo));
for i := low(ExpectBreakSubFoo) to high(ExpectBreakSubFoo) do begin
if not SkipTest(ExpectBreakSubFoo[i]) then begin
WListSub[i] := TCurrentWatch.Create(FWatches);
WListSub[i].Expression := ExpectBreakSubFoo[i].Expression;
WListSub[i].DisplayFormat := ExpectBreakSubFoo[i].DspFormat;
WListSub[i].enabled := True;
end;
end;
(* Start debugging *)
dbg.ShowConsole := True;
dbg.Run;
(* Hit first breakpoint: Test *)
(* SubFoo -- Called with none nil data *)
FDbgOutPutEnable := True;
if (RUN_TEST_ONLY < 0) or (RUN_GDB_TEST_ONLY >= 0) then begin
if RUN_GDB_TEST_ONLY >= 0 then begin
i := RUN_GDB_TEST_ONLY;
for i := low(ExpectBreakFooGdb) to high(ExpectBreakFooGdb) do begin
if not SkipTest(ExpectBreakFooGdb[i]) then begin
FDbgOutPut := '';
dbg.TestCmd(ExpectGdbBrk1NoneNil[i].Exp);
TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectGdbBrk1NoneNil[i], FDbgOutPut);
end
else
for i := low(ExpectGdbBrk1NoneNil) to high(ExpectGdbBrk1NoneNil) do begin
if not SkipTest(ExpectGdbBrk1NoneNil[i]) then begin
FDbgOutPut := '';
dbg.TestCmd(ExpectGdbBrk1NoneNil[i].Exp);
TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectGdbBrk1NoneNil[i], FDbgOutPut);
end;
dbg.TestCmd(ExpectBreakFooGdb[i].Expression);
TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectBreakFooGdb[i], FDbgOutPut);
end;
end;
FDbgOutPutEnable := False;
if (RUN_GDB_TEST_ONLY < 0) or (RUN_TEST_ONLY >= 0) then begin
if RUN_TEST_ONLY >= 0 then begin
i := RUN_TEST_ONLY;
TestWatch('Brk1 ', WList[i], ExpectBrk1NoneNil[i]);
end
else
for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do begin
if not SkipTest(ExpectBrk1NoneNil[i]) then
TestWatch('Brk1 '+IntToStr(i)+' ', WList[i], ExpectBrk1NoneNil[i]);
end;
for i := low(ExpectBreakSubFoo) to high(ExpectBreakSubFoo) do begin
if not SkipTest(ExpectBreakSubFoo[i]) then
TestWatch('Brk1 '+IntToStr(i)+' ', WListSub[i], ExpectBreakSubFoo[i]);
end;
dbg.Run;
(* Hit second breakpoint: Test *)
(* Foo -- Called with none nil data *)
for i := low(ExpectBreakFoo) to high(ExpectBreakFoo) do begin
if not SkipTest(ExpectBreakFoo[i]) then
TestWatch('Brk1 '+IntToStr(i)+' ', WList[i], ExpectBreakFoo[i]);
end;
// TODO: 2nd round, with NIL data
//DebugInteract(dbg);
dbg.Stop;
finally
except
on e: Exception do begin
TestTrue('Error: ' + e.Message, False);
exit;
end;
end;
dbg.Free;
CleanGdb;
if (DbgMemo <> nil) and (TestErrors <> '') then DbgMemo.Lines.Add(TestErrors);
//debugln(FailText)
AssertTestErrors;
end;
procedure TTestWatches.TestWatches;
var
TestExeName: string;
UsedUnits: TUsesDir;
begin
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestWatch')] then exit;
ClearTestErrors;
ClearAllTestArrays;
AddExpectBreakFooGdb;
AddExpectBreakFooAll;
//AddExpectBreakFooMixInfo;
AddExpectBreakFooAndSubFoo;
RunTestWatches('', TestExeName, '', []);
ClearAllTestArrays;
AddExpectBreakFooMixInfo;
with UsedUnits do begin
DirName:= AppDir + 'u1\unitw1.pas';
ExeId:= '';
SymbolType:= stNone;
ExtraOpts:= '';
NamePostFix:= ''
end;
RunTestWatches('unitw1=none', TestExeName, '-dUSE_W1', [UsedUnits]);
if (stStabs in CompilerInfo.SymbolTypes) and (stStabs in DebuggerInfo.SymbolTypes)
then begin
ClearAllTestArrays;
AddExpectBreakFooMixInfo;
with UsedUnits do begin
DirName:= AppDir + 'u1\unitw1.pas';
ExeId:= '';
SymbolType:= stStabs;
ExtraOpts:= '';
NamePostFix:= ''
end;
RunTestWatches('unitw1=stabs', TestExeName, '-dUSE_W1', [UsedUnits]);
end;
if (stDwarf in CompilerInfo.SymbolTypes) and (stDwarf in DebuggerInfo.SymbolTypes)
then begin
ClearAllTestArrays;
AddExpectBreakFooMixInfo;
with UsedUnits do begin
DirName:= AppDir + 'u1\unitw1.pas';
ExeId:= '';
SymbolType:= stDwarf;
ExtraOpts:= '';
NamePostFix:= ''
end;
RunTestWatches('unitw1=dwarf', TestExeName, '-dUSE_W1', [UsedUnits]);
end;
if (stDwarf3 in CompilerInfo.SymbolTypes) and (stDwarf3 in DebuggerInfo.SymbolTypes)
then begin
ClearAllTestArrays;
AddExpectBreakFooMixInfo;
with UsedUnits do begin
DirName:= AppDir + 'u1\unitw1.pas';
ExeId:= '';
SymbolType:= stDwarf3;
ExtraOpts:= '';
NamePostFix:= ''
end;
RunTestWatches('unitw1=dwarf_3', TestExeName, '-dUSE_W1', [UsedUnits]);
end;
AssertTestErrors;
end;
initialization
InitializeExpectBrk1NoneNil;
InitializeExpectGdbBrk1NoneNil;
RegisterDbgTest(TTestWatches);
end.