diff --git a/components/lazdebuggergdbmi/test/TestApps/ArgVPrg.pas b/components/lazdebuggergdbmi/test/TestApps/ArgVPrg.pas index c7712585f0..de390b8201 100644 --- a/components/lazdebuggergdbmi/test/TestApps/ArgVPrg.pas +++ b/components/lazdebuggergdbmi/test/TestApps/ArgVPrg.pas @@ -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. diff --git a/components/lazdebuggergdbmi/test/TestApps/EnvPrg.pas b/components/lazdebuggergdbmi/test/TestApps/EnvPrg.pas index 9f749a0a59..c8a86e479e 100644 --- a/components/lazdebuggergdbmi/test/TestApps/EnvPrg.pas +++ b/components/lazdebuggergdbmi/test/TestApps/EnvPrg.pas @@ -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. diff --git a/components/lazdebuggergdbmi/test/gdblist.txt.sample b/components/lazdebuggergdbmi/test/gdblist.txt.sample index 70aeff3bc7..abf6dd90ee 100644 --- a/components/lazdebuggergdbmi/test/gdblist.txt.sample +++ b/components/lazdebuggergdbmi/test/gdblist.txt.sample @@ -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 diff --git a/components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas b/components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas index 5587ea7749..389772d91b 100644 --- a/components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas +++ b/components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas @@ -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; diff --git a/components/lazdebuggergdbmi/test/testargv.pas b/components/lazdebuggergdbmi/test/testargv.pas index 259398205b..a33b936074 100644 --- a/components/lazdebuggergdbmi/test/testargv.pas +++ b/components/lazdebuggergdbmi/test/testargv.pas @@ -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. diff --git a/components/lazdebuggergdbmi/test/testenvironment.pas b/components/lazdebuggergdbmi/test/testenvironment.pas index 31bb9c3bb5..c083ba6c66 100644 --- a/components/lazdebuggergdbmi/test/testenvironment.pas +++ b/components/lazdebuggergdbmi/test/testenvironment.pas @@ -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. diff --git a/components/lazdebuggers/lazdebugtestbase/testdbgcompilerprocess.pas b/components/lazdebuggers/lazdebugtestbase/testdbgcompilerprocess.pas index ec1270c463..6935e862e9 100644 --- a/components/lazdebuggers/lazdebugtestbase/testdbgcompilerprocess.pas +++ b/components/lazdebuggers/lazdebugtestbase/testdbgcompilerprocess.pas @@ -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; diff --git a/components/lazdebuggers/lazdebugtestbase/testdbgconfig.pas b/components/lazdebuggers/lazdebugtestbase/testdbgconfig.pas index f73171214c..427304437e 100644 --- a/components/lazdebuggers/lazdebugtestbase/testdbgconfig.pas +++ b/components/lazdebuggers/lazdebugtestbase/testdbgconfig.pas @@ -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; diff --git a/components/lazdebuggers/lazdebugtestbase/testdbgtestsuites.pas b/components/lazdebuggers/lazdebugtestbase/testdbgtestsuites.pas index 386e174405..95b2c1bfb3 100644 --- a/components/lazdebuggers/lazdebugtestbase/testdbgtestsuites.pas +++ b/components/lazdebuggers/lazdebugtestbase/testdbgtestsuites.pas @@ -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; diff --git a/components/lazdebuggers/lazdebugtestbase/ttestdbgexecuteables.pas b/components/lazdebuggers/lazdebugtestbase/ttestdbgexecuteables.pas index 934fc62eb0..5b6f3b89b5 100644 --- a/components/lazdebuggers/lazdebugtestbase/ttestdbgexecuteables.pas +++ b/components/lazdebuggers/lazdebugtestbase/ttestdbgexecuteables.pas @@ -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';