mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-07-23 21:46:13 +02:00
Test Debugger, GDBMI: ArgC/Env Utf8 handling for cygwin builds
git-svn-id: trunk@64876 -
This commit is contained in:
martin
parent
d515edebc4
commit
1b907520c7
@ -6,16 +6,31 @@ uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
{$IFDEF WINDOWS}
|
||||
windows,
|
||||
{$ENDIF}
|
||||
Classes, sysutils
|
||||
{ you can add units after this };
|
||||
|
||||
var
|
||||
i: Integer;
|
||||
p: PChar;
|
||||
s: String;
|
||||
S: String;
|
||||
{$IFDEF WINDOWS}
|
||||
w: LPWSTR;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
|
||||
begin
|
||||
{$IFDEF WINDOWS}
|
||||
w := GetCommandLineW;
|
||||
s := '';
|
||||
for i := 1 to argc - 1 do begin
|
||||
for i := 0 to strlen(w) - 1 do
|
||||
s := s + IntToHex(ord(w[i]), 4);
|
||||
{$ELSE}
|
||||
s := '';
|
||||
for i := 0 to argc - 1 do begin
|
||||
p := (argv+i)^;
|
||||
while p^ <> #0 do begin
|
||||
s := s + IntToHex(ord(p^), 2);
|
||||
@ -23,6 +38,9 @@ begin
|
||||
end;
|
||||
s := s + ' ';
|
||||
end;
|
||||
{$ENDIF}
|
||||
Freemem(GetMem(1));
|
||||
Freemem(GetMem(1)); // line 40 breakpoint
|
||||
Freemem(GetMem(1));
|
||||
end.
|
||||
|
||||
|
||||
@ -1,13 +1,31 @@
|
||||
program EnvPrg;
|
||||
{$H-}
|
||||
|
||||
uses sysutils;
|
||||
uses
|
||||
{$IFDEF UNIX} cwstring, {$ENDIF}
|
||||
sysutils;
|
||||
|
||||
var
|
||||
s: String;
|
||||
u: UnicodeString;
|
||||
e, S: string;
|
||||
i: Integer;
|
||||
begin
|
||||
s := GetEnvironmentVariable('ETEST1');
|
||||
if s = 'ab123c' then
|
||||
Freemem(GetMem(1))
|
||||
else
|
||||
Freemem(GetMem(2));
|
||||
{$IFDEF UNIX}
|
||||
e := GetEnvironmentVariable(AnsiString('ETEST1'));
|
||||
{$ELSE}
|
||||
u := GetEnvironmentVariable(UnicodeString('ETEST1'));
|
||||
e := UTF8Encode(u);
|
||||
{$ENDIF}
|
||||
s := '';
|
||||
for i := 1 to length(e) do
|
||||
s := s + IntToHex(ord(e[i]), 2);
|
||||
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
while false do ;
|
||||
end.
|
||||
|
||||
@ -20,6 +20,10 @@ version=070000
|
||||
symbols=none,gs,gw,gwset
|
||||
bits=64
|
||||
//symbols=none,gs,gw,gwset,gw3
|
||||
//flags=no_env_u2,no_arg_u2
|
||||
// no_env_u2 Does not support full utf8 for env
|
||||
// no_arg_u2 Does not support full utf8 for exec-args
|
||||
|
||||
|
||||
[gdb 7.3-50 with patches]
|
||||
exe=C:\GDB\7.3-50\gdb.exe
|
||||
|
||||
@ -31,6 +31,11 @@ type
|
||||
|
||||
TGDBMIDebuggerClass = class of TGDBMIDebugger;
|
||||
|
||||
{ TTestDebuggerHelper }
|
||||
|
||||
TTestDebuggerHelper = class helper for TDebuggerIntf
|
||||
procedure AddTestBreakPoint(AFilename: String; ALine: Integer; AEnabled: Boolean = True);
|
||||
end;
|
||||
|
||||
|
||||
TDebuggerInfo = TExternalExeInfo;
|
||||
@ -88,7 +93,7 @@ type
|
||||
ResultText: String; ResultDBGType: TDBGType);
|
||||
public
|
||||
function EvaluateWait(const AExpression: String; var ARes: String;
|
||||
var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags = []): Boolean;
|
||||
var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags = []; ATimeOut: Integer = -1): Boolean;
|
||||
end;
|
||||
|
||||
|
||||
@ -163,6 +168,18 @@ begin
|
||||
Result := Debuggers;
|
||||
end;
|
||||
|
||||
{ TTestDebuggerHelper }
|
||||
|
||||
procedure TTestDebuggerHelper.AddTestBreakPoint(AFilename: String;
|
||||
ALine: Integer; AEnabled: Boolean);
|
||||
begin
|
||||
with BreakPoints.Add(AFilename, ALine, True) do begin
|
||||
Enabled := AEnabled;
|
||||
InitialEnabled := AEnabled;
|
||||
EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TGDBMIDebuggerForTest }
|
||||
|
||||
procedure TGDBMIDebuggerForTest.EvalCallBack(Sender: TObject;
|
||||
@ -174,14 +191,22 @@ begin
|
||||
end;
|
||||
|
||||
function TGDBMIDebuggerForTest.EvaluateWait(const AExpression: String;
|
||||
var ARes: String; var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags
|
||||
): Boolean;
|
||||
var ARes: String; var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags;
|
||||
ATimeOut: Integer): Boolean;
|
||||
var
|
||||
t: QWord;
|
||||
begin
|
||||
FEvalResType := nil;
|
||||
FEvalDone := false;
|
||||
t := GetTickCount64;
|
||||
inherited Evaluate(AExpression, @EvalCallBack, EvalFlags);
|
||||
while not FEvalDone do begin
|
||||
Application.ProcessMessages;
|
||||
sleep(5);
|
||||
if ATimeOut > 0 then begin
|
||||
if GetTickCount64 - t > ATimeOut then
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
ARes := FEvalRes;
|
||||
AResType := FEvalResType;
|
||||
|
||||
@ -5,83 +5,304 @@ unit TestArgV;
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, fpcunit, testutils, testregistry, TestBase,
|
||||
GDBMIDebugger, LCLProc, FileUtil, LazUTF8, DbgIntfDebuggerBase,
|
||||
TestDbgControl, TestDbgTestSuites, TestDbgConfig, TestWatches;
|
||||
SysUtils, fpcunit, testutils, testregistry, TestBase, GDBMIDebugger, LCLProc,
|
||||
FileUtil, LazUTF8, DbgIntfDebuggerBase, TestDbgControl, TestDbgTestSuites,
|
||||
TestDbgConfig, TestDbgCompilerProcess, TestWatches;
|
||||
|
||||
const
|
||||
BREAK_LINE_ARGV = 26;
|
||||
BREAK_LINE_ARGV = 40;
|
||||
|
||||
type
|
||||
|
||||
{ TTestEnvironment }
|
||||
|
||||
{ TTestArgV }
|
||||
|
||||
TTestArgV = class(TGDBTestCase)
|
||||
{ TTestArgBase }
|
||||
|
||||
TTestArgBase = class(TGDBTestCase)
|
||||
protected
|
||||
function TestHex(const s: array of string): String; virtual;
|
||||
function TestHex64(const w: WideString): String;
|
||||
function TestSourceName: String; virtual;
|
||||
function TestBreakLine: integer; virtual;
|
||||
|
||||
function StartTest(ConrolVar: Pointer; var dbg: TGDBMIDebugger; NamePostFix: String=''): Boolean;
|
||||
procedure RunAndCheckVal(dbg: TGDBMIDebugger; AName: String; const AExp: Array of string);
|
||||
procedure EndTest(dbg: TGDBMIDebugger);
|
||||
end;
|
||||
|
||||
{ TTestArgWideBase }
|
||||
|
||||
TTestArgWinWideBase = class(TTestArgBase)
|
||||
protected
|
||||
function TestHex(const s: array of string): String; override;
|
||||
end;
|
||||
|
||||
TTestArgV = class(TTestArgWinWideBase)
|
||||
published
|
||||
procedure TestArgv;
|
||||
procedure TestArgvBasic;
|
||||
procedure TestArgvBasicTab;
|
||||
procedure TestArgvBasicQuote;
|
||||
procedure TestArgvUtf1;
|
||||
procedure TestArgvUtf2;
|
||||
end;
|
||||
|
||||
{ TTestExeName }
|
||||
|
||||
TTestExeName = class(TTestArgWinWideBase)
|
||||
published
|
||||
procedure TestExeNameUtf1;
|
||||
procedure TestExeNameUtf2;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
var
|
||||
ControlTestArgV: Pointer;
|
||||
ControlTestArgV, ControlTestArgVBasic, ControlTestArgVBasicTab, ControlTestArgVBasicQuote,
|
||||
ControlTestArgVUtf1, ControlTestArgVUtf2: Pointer;
|
||||
ControlTestExeName: Pointer;
|
||||
|
||||
{ TTestArgWideBase }
|
||||
|
||||
function TTestArgWinWideBase.TestHex(const s: array of string): String;
|
||||
var
|
||||
w: WideString;
|
||||
i: Integer;
|
||||
begin
|
||||
{$IFDEF WINDOWS}
|
||||
w := '';
|
||||
for i := 0 to Length(s) - 1 do begin
|
||||
if w <> '' then w := w + ' ';
|
||||
w := w + UTF8Decode(s[i]);
|
||||
end;
|
||||
Result := TestHex64(w);
|
||||
exit;
|
||||
{$ENDIF}
|
||||
Result := inherited TestHex(s);
|
||||
end;
|
||||
|
||||
{ TTestExeName }
|
||||
|
||||
procedure TTestExeName.TestExeNameUtf1;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestExeName, dbg, 'äÖ') then
|
||||
exit;
|
||||
|
||||
try
|
||||
dbg.Arguments := '';
|
||||
RunAndCheckVal(dbg, 'äÖ', ['äÖ']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestExeName.TestExeNameUtf2;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestExeName, dbg, 'あｓ') then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_exe_u2') then
|
||||
FIgnoreReason := 'no_exe_u2 flag';
|
||||
|
||||
try
|
||||
dbg.Arguments := '';
|
||||
RunAndCheckVal(dbg, 'あｓ', ['あｓ']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TTestArgV }
|
||||
|
||||
procedure TTestArgV.TestArgv;
|
||||
function TTestArgBase.StartTest(ConrolVar: Pointer; var dbg: TGDBMIDebugger;
|
||||
NamePostFix: String): Boolean;
|
||||
var
|
||||
TestExeName, s: String;
|
||||
begin
|
||||
Result := False;
|
||||
if SkipTest then exit;
|
||||
if not TestControlCanTest(ConrolVar) then exit;
|
||||
|
||||
Result := True;
|
||||
ClearTestErrors;
|
||||
TestCompile(AppDir + TestSourceName, TestExeName);
|
||||
|
||||
if NamePostFix <> '' then begin
|
||||
s := TestExeName;
|
||||
TestExeName := UTF8StringReplace(s, 'ArgVPrg', 'ArgVPrg'+NamePostFix, []);
|
||||
RenameFile(s, TestExeName);
|
||||
CreatedExecutableList.AddExe(TestExeName, '');
|
||||
end;
|
||||
|
||||
dbg := StartGDB(AppDir, TestExeName);
|
||||
end;
|
||||
|
||||
function TTestArgBase.TestHex(const s: array of string): String;
|
||||
var
|
||||
i, j: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
for i := 0 to length(s)-1 do begin
|
||||
for j := 1 to length(s[i]) do
|
||||
Result := Result + IntToHex(ord(s[i][j]), 2);
|
||||
Result := Result + ' ';
|
||||
end;
|
||||
delete(Result, Length(Result), 1);
|
||||
end;
|
||||
|
||||
function TTestArgBase.TestHex64(const w: WideString): String;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
TestExeName, s, s2, s3: string;
|
||||
t: TDBGType;
|
||||
i: Integer;
|
||||
begin
|
||||
if SkipTest then exit;
|
||||
if not TestControlCanTest(ControlTestArgV) then exit;
|
||||
Result := '';
|
||||
for i := 1 to Length(w) do
|
||||
Result := Result + IntToHex(ord(w[i]), 4);
|
||||
end;
|
||||
|
||||
ClearTestErrors;
|
||||
TestCompile(AppDir + 'ArgVPrg.pas', TestExeName);
|
||||
function TTestArgBase.TestSourceName: String;
|
||||
begin
|
||||
Result := 'ArgVPrg.pas';
|
||||
end;
|
||||
|
||||
s := 'env value 1';
|
||||
try
|
||||
dbg := StartGDB(AppDir, TestExeName);
|
||||
dbg.Arguments := 'a b c ä ö ';
|
||||
|
||||
with dbg.BreakPoints.Add('ArgVPrg.pas', BREAK_LINE_ARGV) do begin
|
||||
InitialEnabled := True;
|
||||
Enabled := True;
|
||||
end;
|
||||
function TTestArgBase.TestBreakLine: integer;
|
||||
begin
|
||||
Result := BREAK_LINE_ARGV;
|
||||
end;
|
||||
|
||||
procedure TTestArgBase.RunAndCheckVal(dbg: TGDBMIDebugger; AName: String;
|
||||
const AExp: array of string);
|
||||
var
|
||||
s, s2: string;
|
||||
t: TDBGType;
|
||||
begin
|
||||
dbg.AddTestBreakPoint(TestSourceName, TestBreakLine);
|
||||
dbg.Run;
|
||||
|
||||
TestTrue(s+' not in error state', dbg.State <> dsError, 0);
|
||||
if not TestTrue(s+' not in error state', dbg.State <> dsError, 0) then
|
||||
exit;
|
||||
if not TestTrue(s+' not in stop state', dbg.State <> dsStop, 0) then
|
||||
exit;
|
||||
|
||||
t := nil;
|
||||
TestTrue('Can eval', dbg.EvaluateWait('s', s, t));
|
||||
TestTrue('Can eval', dbg.EvaluateWait('S', s, t, [], 15000));
|
||||
FreeAndNil(t);
|
||||
|
||||
TestTrue('a b c in '+s, pos('61 62 63', s) > 0);
|
||||
s2 := TestHex(AExp);
|
||||
TestTrue(AName + '[['+s2+']] in '+s, pos(s2, s) > 0);
|
||||
end;
|
||||
|
||||
s2 := UTF8ToSys('ä');
|
||||
s3 := ' ';
|
||||
for i := 1 to length(s2) do
|
||||
s3 := s3 + IntToHex(ord(s2[i]), 2);
|
||||
s3 := s3 + ' ';
|
||||
|
||||
TestTrue(' ä in '+s, pos(s3, s) > 0);
|
||||
|
||||
|
||||
finally
|
||||
dbg.Done;
|
||||
CleanGdb;
|
||||
dbg.Free;
|
||||
end;
|
||||
procedure TTestArgBase.EndTest(dbg: TGDBMIDebugger);
|
||||
begin
|
||||
dbg.Done;
|
||||
CleanGdb;
|
||||
dbg.Free;
|
||||
|
||||
AssertTestErrors;
|
||||
end;
|
||||
|
||||
procedure TTestArgV.TestArgvBasic;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestArgVBasic, dbg) then
|
||||
exit;
|
||||
|
||||
try
|
||||
dbg.Arguments := 'a b c -d=e1 ab';
|
||||
{$IFDEF WINDOWS}
|
||||
RunAndCheckVal(dbg, 'a b c -d=e1 a\b$^!)x', ['a b c -d=e1 ab']);
|
||||
{$ELSE}
|
||||
RunAndCheckVal(dbg, 'a b c -d=e1 ab', ['a', 'b', 'c', '-d=e1', 'ab']);
|
||||
{$ENDIF}
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestArgV.TestArgvBasicTab;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestArgVBasicTab, dbg) then
|
||||
exit;
|
||||
|
||||
try
|
||||
dbg.Arguments := 'd=e1 "A'#9'x"';
|
||||
{$IFDEF WINDOWS}
|
||||
RunAndCheckVal(dbg, 'd=e1 "A'#9'x"', ['d=e1 "A'#9'x"']);
|
||||
{$ELSE}
|
||||
RunAndCheckVal(dbg, 'd=e1"A'#9'x"', ['d=e1', 'A'#9'x']);
|
||||
{$ENDIF}
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestArgV.TestArgvBasicQuote;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestArgVBasicQuote, dbg) then
|
||||
exit;
|
||||
|
||||
try
|
||||
{$IFDEF WINDOWS}
|
||||
//dbg.Arguments := '"A "" B"';
|
||||
//RunAndCheckVal(dbg, '', ['A " B']);
|
||||
{$ENDIF}
|
||||
{$IFDEF UNIX}
|
||||
dbg.Arguments := '"A B" ''a b''';
|
||||
RunAndCheckVal(dbg, '', ['A B', 'a b']);
|
||||
{$ENDIF}
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestArgV.TestArgvUtf1;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestArgVUtf1, dbg) then
|
||||
exit;
|
||||
|
||||
try
|
||||
dbg.Arguments := 'a b c ä ö ';
|
||||
RunAndCheckVal(dbg, 'a b c ä ö ', ['a', 'b', 'c', 'ä', 'ö']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestArgV.TestArgvUtf2;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestArgVUtf2, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_arg_u2') then
|
||||
FIgnoreReason := 'no_arg_u2 flag';
|
||||
|
||||
try
|
||||
dbg.Arguments := 'a b c ä ö 😁 X あｓｆ';
|
||||
RunAndCheckVal(dbg, 'a b c ä ö 😁 X あｓｆ', ['a', 'b', 'c', 'ä', 'ö', '😁', 'X', 'あｓｆ']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterDbgTest(TTestArgV);
|
||||
ControlTestArgV := TestControlRegisterTest('TTestArgV');
|
||||
RegisterDbgTest(TTestExeName);
|
||||
ControlTestArgV := TestControlRegisterTest('TTestArgV');
|
||||
ControlTestArgVBasic := TestControlRegisterTest('ArgV Basic', ControlTestArgV);
|
||||
ControlTestArgVBasicTab := TestControlRegisterTest('ArgV Basic Tab', ControlTestArgV);
|
||||
ControlTestArgVBasicQuote := TestControlRegisterTest('ArgV Basic Quote', ControlTestArgV);
|
||||
ControlTestArgVUtf1 := TestControlRegisterTest('ArgV Utf1', ControlTestArgV);
|
||||
ControlTestArgVUtf2 := TestControlRegisterTest('ArgV Utf2', ControlTestArgV);
|
||||
ControlTestExeName := TestControlRegisterTest('TTestExeName');
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -7,111 +7,158 @@ interface
|
||||
uses
|
||||
SysUtils, fpcunit, testutils, testregistry, TestBase, GDBMIDebugger, LCLProc,
|
||||
DbgIntfDebuggerBase, TestDbgControl, TestDbgTestSuites, TestDbgConfig,
|
||||
TestWatches;
|
||||
TestWatches, TestArgV;
|
||||
|
||||
const
|
||||
BREAK_LINE_ENV1 = 10;
|
||||
BREAK_LINE_ENV2 = 12;
|
||||
|
||||
type
|
||||
|
||||
{ TTestEnvironment }
|
||||
|
||||
TTestEnvironment = class(TGDBTestCase)
|
||||
TTestEnvironment = class(TTestArgBase)
|
||||
private
|
||||
FCurLine: Integer;
|
||||
protected
|
||||
procedure DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
|
||||
//function TestHex(const s: array of string): String; override;
|
||||
|
||||
function TestSourceName: String; override;
|
||||
function TestBreakLine: integer; override;
|
||||
published
|
||||
procedure TestEnv;
|
||||
procedure TestEnvBasic;
|
||||
procedure TestEnvBasicTab;
|
||||
procedure TestEnvBasicQuote;
|
||||
procedure TestEnvUtf1;
|
||||
procedure TestEnvUtf2;
|
||||
end;
|
||||
|
||||
implementation
|
||||
var
|
||||
ControlTestEnvironment: Pointer;
|
||||
ControlTestEnvironment, ControlTestEnvironmentBasic, ControlTestEnvironmentTab,
|
||||
ControlTestEnvironmentUtf1, ControlTestEnvironmentUtf2: Pointer;
|
||||
|
||||
{ TTestEnvironment }
|
||||
|
||||
procedure TTestEnvironment.DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
|
||||
//function TTestEnvironment.TestHex(const s: array of string): String;
|
||||
//var
|
||||
// w: WideString;
|
||||
// i: Integer;
|
||||
//begin
|
||||
// w := '';
|
||||
// for i := 0 to Length(s) - 1 do begin
|
||||
// if w <> '' then w := w + ' ';
|
||||
// w := w + UTF8Decode(s[i]);
|
||||
// end;
|
||||
// Result := TestHex64(w);
|
||||
//end;
|
||||
|
||||
function TTestEnvironment.TestSourceName: String;
|
||||
begin
|
||||
FCurLine := ALocation.SrcLine;
|
||||
Result := 'EnvPrg.pas';
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnv;
|
||||
function TTestEnvironment.TestBreakLine: integer;
|
||||
begin
|
||||
Result := 25;
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnvBasic;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
TestExeName, s: string;
|
||||
IgnoreRes: String;
|
||||
begin
|
||||
if SkipTest then exit;
|
||||
if not TestControlCanTest(ControlTestEnvironment) then exit;
|
||||
if not StartTest(ControlTestEnvironmentUtf2, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_env') then
|
||||
FIgnoreReason := 'no_env flag';
|
||||
|
||||
ClearTestErrors;
|
||||
TestCompile(AppDir + 'EnvPrg.pas', TestExeName);
|
||||
|
||||
IgnoreRes := '';
|
||||
{$IFDEF Windows}
|
||||
if (DebuggerInfo.Version > 060600) and
|
||||
(DebuggerInfo.Version < 070400)
|
||||
then
|
||||
IgnoreRes := 'broken gdb';
|
||||
{$ENDIF}
|
||||
|
||||
s := 'env value 1';
|
||||
dbg := StartGDB(AppDir, TestExeName);
|
||||
try
|
||||
dbg.OnCurrent := @DoCurrent;
|
||||
dbg.Environment.Add('ETEST1=ab123c');
|
||||
with dbg.BreakPoints.Add('EnvPrg.pas', BREAK_LINE_ENV1) do begin
|
||||
InitialEnabled := True;
|
||||
Enabled := True;
|
||||
end;
|
||||
with dbg.BreakPoints.Add('EnvPrg.pas', BREAK_LINE_ENV2) do begin
|
||||
InitialEnabled := True;
|
||||
Enabled := True;
|
||||
end;
|
||||
|
||||
dbg.Run;
|
||||
|
||||
TestTrue(s+' not in error state', dbg.State <> dsError, 0);
|
||||
TestTrue(s+' at break', FCurLine = BREAK_LINE_ENV1, 0, IgnoreRes);
|
||||
RunAndCheckVal(dbg, 'ab123c', ['ab123c']);
|
||||
finally
|
||||
dbg.Done;
|
||||
CleanGdb;
|
||||
dbg.Free;
|
||||
EndTest(dbg);
|
||||
end;
|
||||
|
||||
s := 'env value 2';
|
||||
dbg := StartGDB(AppDir, TestExeName);
|
||||
try
|
||||
dbg.OnCurrent := @DoCurrent;
|
||||
dbg.Environment.Add('ETEST1=xxx');
|
||||
with dbg.BreakPoints.Add('EnvPrg.pas', BREAK_LINE_ENV1) do begin
|
||||
InitialEnabled := True;
|
||||
Enabled := True;
|
||||
end;
|
||||
with dbg.BreakPoints.Add('EnvPrg.pas', BREAK_LINE_ENV2) do begin
|
||||
InitialEnabled := True;
|
||||
Enabled := True;
|
||||
end;
|
||||
|
||||
dbg.Run;
|
||||
|
||||
TestTrue(s+' not in error state', dbg.State <> dsError, 0);
|
||||
TestTrue(s+' at break', FCurLine = BREAK_LINE_ENV2, 0);
|
||||
finally
|
||||
dbg.Done;
|
||||
CleanGdb;
|
||||
dbg.Free;
|
||||
end;
|
||||
|
||||
|
||||
AssertTestErrors;
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnvBasicTab;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestEnvironmentTab, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_env') then
|
||||
FIgnoreReason := 'no_env flag';
|
||||
|
||||
try
|
||||
dbg.Environment.Add('ETEST1=a'#9'b');
|
||||
RunAndCheckVal(dbg, 'a'#9'b', ['a'#9'b']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnvBasicQuote;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestEnvironmentBasic, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_env') then
|
||||
FIgnoreReason := 'no_env flag';
|
||||
|
||||
try
|
||||
dbg.Environment.Add('ETEST1=ab123c"'' \" a\b$^!)\''x');
|
||||
RunAndCheckVal(dbg, 'ab123c"'' \" a\b$^!)\''x', ['ab123c"'' \" a\b$^!)\''x']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnvUtf1;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestEnvironmentUtf1, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_env') then
|
||||
FIgnoreReason := 'no_env flag';
|
||||
if Compiler.Version < 030000 then
|
||||
FIgnoreReason := FIgnoreReason + 'fpc to old';
|
||||
|
||||
try
|
||||
dbg.Environment.Add('ETEST1=aäöx');
|
||||
RunAndCheckVal(dbg, 'aäöx', ['aäöx']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestEnvironment.TestEnvUtf2;
|
||||
var
|
||||
dbg: TGDBMIDebugger;
|
||||
begin
|
||||
if not StartTest(ControlTestEnvironment, dbg) then
|
||||
exit;
|
||||
if Debugger.HasFlag('no_env') then
|
||||
FIgnoreReason := 'no_env flag';
|
||||
if Debugger.HasFlag('no_env_u2') then
|
||||
FIgnoreReason := 'no_env_u2 flag';
|
||||
if Compiler.Version < 030000 then
|
||||
FIgnoreReason := FIgnoreReason + 'fpc to old';
|
||||
|
||||
try
|
||||
dbg.Environment.Add('ETEST1=a b c ä ö 😁 X あｓｆ');
|
||||
RunAndCheckVal(dbg, 'a b c ä ö 😁 X あｓｆ', ['a b c ä ö 😁 X あｓｆ']);
|
||||
finally
|
||||
EndTest(dbg);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
RegisterDbgTest(TTestEnvironment);
|
||||
ControlTestEnvironment := TestControlRegisterTest('TTestEnvironment');
|
||||
ControlTestEnvironmentBasic := TestControlRegisterTest('TTestEnvironment Basic', ControlTestEnvironment);
|
||||
ControlTestEnvironmentTab := TestControlRegisterTest('TTestEnvironment Tab', ControlTestEnvironment);
|
||||
ControlTestEnvironmentUtf1 := TestControlRegisterTest('TTestEnvironment Utf1', ControlTestEnvironment);
|
||||
ControlTestEnvironmentUtf2 := TestControlRegisterTest('TTestEnvironment Utf2', ControlTestEnvironment);
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -37,7 +37,6 @@ type
|
||||
|
||||
procedure ClearFilesAndDirs;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
|
||||
@ -67,6 +66,8 @@ var
|
||||
CreatedExecutableList: TCreatedExecutableList;
|
||||
CreatedLibDirList: TCreatedExecutableList;
|
||||
|
||||
implementation
|
||||
|
||||
class operator TCreatedExecutable. = (a, b: TCreatedExecutable): Boolean;
|
||||
begin
|
||||
raise Exception.Create('unreachable'); // should never enter here
|
||||
@ -326,9 +327,12 @@ end;
|
||||
function TCompilerProcess.TestCompile(const FpcExe, FpcOpts, PascalPrgFile,
|
||||
ExeName: string; ForceReCompile: Boolean): boolean;
|
||||
var
|
||||
CmdLine: string;
|
||||
CmdLine, s: string;
|
||||
begin
|
||||
CmdLine := FpcExe + ' -B -MObjFPC -FUlib -o'+ ExeName + ' ' + FpcOpts + ' ' + PascalPrgFile;
|
||||
s := ExeName;
|
||||
if pos(' ', s) > 0 then
|
||||
s := '"' + s + '"';
|
||||
CmdLine := FpcExe + ' -B -MObjFPC -FUlib -o'+ s + ' ' + FpcOpts + ' ' + PascalPrgFile;
|
||||
|
||||
if ForceReCompile then begin
|
||||
Result := False;
|
||||
|
||||
@ -50,6 +50,7 @@ type
|
||||
SymbolTypes: TSymbolTypes;
|
||||
CpuBitTypes: TCpuBitTypes;
|
||||
ExtraOpts: string;
|
||||
CustomFlags, _CustomFlags: string;
|
||||
end;
|
||||
|
||||
type
|
||||
@ -176,7 +177,7 @@ end;
|
||||
|
||||
procedure TBaseList.SetAttribute(AIndex: Integer; const AAttr, AValue: string);
|
||||
begin
|
||||
case StringCase(AAttr, ['exe', 'symbols', 'opts', 'vers', 'version', 'bittype', 'bits'], True, False) of
|
||||
case StringCase(AAttr, ['exe', 'symbols', 'opts', 'vers', 'version', 'bittype', 'bits', 'flags'], True, False) of
|
||||
0: begin // exe
|
||||
FList[AIndex].ExeName := AValue;
|
||||
end;
|
||||
@ -192,6 +193,11 @@ begin
|
||||
5,6: begin
|
||||
FList[AIndex].CpuBitTypes := StrToCpuBitTypes(AValue);
|
||||
end;
|
||||
7: begin // flags
|
||||
FList[AIndex].CustomFlags := AValue;
|
||||
// each flag enclosed by , / ,flag1,flag2,
|
||||
FList[AIndex]._CustomFlags := ','+StringReplace(lowercase(AValue), ' ', '', [rfReplaceAll])+',';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -41,6 +41,7 @@ type
|
||||
function GetCompiler: TTestDbgCompiler;
|
||||
function GetDebugger: TTestDbgDebugger;
|
||||
protected
|
||||
FIgnoreReason: String;
|
||||
// TestResults
|
||||
procedure AddTestError (s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
|
||||
procedure AddTestError (s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
|
||||
@ -190,6 +191,8 @@ begin
|
||||
IgnoreReason := 'FPC ('+IntToStr(i)+') to old, required:'+IntToStr(MinFpcVers);
|
||||
end;
|
||||
IgnoreReason := IgnoreReason + AIgnoreReason;
|
||||
if IgnoreReason = '' then
|
||||
IgnoreReason := FIgnoreReason;
|
||||
|
||||
if IgnoreReason <> '' then begin
|
||||
FIgnoredErrors := FIgnoredErrors + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
|
||||
@ -591,6 +594,7 @@ begin
|
||||
FTotalErrorCnt := 0;
|
||||
FTotalIgnoredErrorCnt := 0;
|
||||
FTotalUnexpectedSuccessCnt := 0;
|
||||
FIgnoreReason := '';
|
||||
|
||||
for i := 0 to DebugLogger.LogGroupList.Count - 1 do
|
||||
DebugLogger.LogGroupList[i]^.Enabled := True;
|
||||
|
||||
@ -7,7 +7,7 @@ interface
|
||||
uses
|
||||
Classes, SysUtils, fgl, TestDbgConfig, TestDbgCompilerProcess,
|
||||
TestOutputLogger, TTestDebuggerClasses, TestCommonSources, LazFileUtils,
|
||||
LazLoggerBase, FileUtil, DbgIntfDebuggerBase, fpcunit;
|
||||
LazLoggerBase, FileUtil, LazStringUtils, DbgIntfDebuggerBase, fpcunit;
|
||||
|
||||
type
|
||||
|
||||
@ -29,6 +29,8 @@ type
|
||||
public
|
||||
constructor Create(AnExternalExeInfo: TExternalExeInfo);
|
||||
function FullName: String;
|
||||
function HasFlag(const f: string): boolean;
|
||||
function HasFlags(const f: array of string): boolean;
|
||||
|
||||
property Name: string read GetName;
|
||||
property Version: Integer read GetVersion;
|
||||
@ -199,6 +201,23 @@ begin
|
||||
Result := Name;
|
||||
end;
|
||||
|
||||
function TTestDbgExternalExe.HasFlag(const f: string): boolean;
|
||||
begin
|
||||
Result := HasFlags([f]);
|
||||
end;
|
||||
|
||||
function TTestDbgExternalExe.HasFlags(const f: array of string): boolean;
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
Result := True;
|
||||
for s in f do
|
||||
if PosI(','+s+',', FullInfo._CustomFlags) > 0 then
|
||||
exit;
|
||||
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
{ TTestDbgCompiler }
|
||||
|
||||
function TTestDbgCompiler.GetCpuBitType: TCpuBitType;
|
||||
@ -285,7 +304,7 @@ begin
|
||||
NamePostFix := NamePostFix + NewExeID;
|
||||
end;
|
||||
|
||||
AnExeName := ExePath + AnExeName + '_'+IntToStr(GetProcessID)+'_'+ SymbolTypeNames[SymbolType] + '_' + NameToFileName(Self.Name) + NamePostFix + GetExeExt;
|
||||
AnExeName := ExePath + AnExeName + NamePostFix + '_'+IntToStr(GetProcessID)+'_'+ SymbolTypeNames[SymbolType] + '_' + NameToFileName(Self.Name) + GetExeExt;
|
||||
|
||||
{$IFDEF windows}
|
||||
ExtraArgs := ExtraArgs + ' -WG';
|
||||
|
||||
Loading…
Reference in New Issue
Block a user