1 unit TestDbgTestSuites;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, TTestDbgExecuteables, TestDbgControl, TestDbgConfig,
9 TestOutputLogger, TestCommonSources, LazFileUtils, LazLogger,
10 DbgIntfDebuggerBase, StrUtils, fpcunit, testregistry, RegExpr;
11
12 const
13 EqIgnoreCase = False; // for TestEquals(..., CaseSense, ...);
14 EqMatchCase = True;
15
16 type
17 TDBGTestsuite = class;
18 TDBGStates = set of TDBGState;
19
20 { TDbgBaseTestsuite }
21
22 TDbgBaseTestsuite = class(TTestSuite)
23 private
24 FInRun: Integer;
25 FDirectParent: TDbgBaseTestsuite;
26 FOverviewReport: String;
27 procedure LogOverviewReport;
28 protected
29 procedure Clear; virtual;
30 public
31 procedure Run(AResult: TTestResult); override;
32 procedure RunTest(ATest: TTest; AResult: TTestResult); override;
33 procedure AddTest(ATest: TTest); overload; override;
34
35 procedure AddOverviewLog(Const AText: String);
36 end;
37
38 { TDBGTestCase }
39
40 TDBGTestCase = class(TTestCase)
41 private
42 FParent: TDBGTestsuite;
43 FDirectParent: TDbgBaseTestsuite;
44 // TestResults
45 FTestBaseName: String;
46 FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String;
47 FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer;
48 FInTestBlock: integer;
49 FInTestBlockTxt: String;
50 FInTestBlockRes: (tbOk, tbErr, tbIgnore, tbUnexpected);
51 FTotalErrorCnt, FTotalIgnoredErrorCnt, FTotalUnexpectedSuccessCnt: Integer;
52 FRegX: TRegExpr;
53
54 // Logging
55 FLogLock: TRTLCriticalSection;
56 FLogFile, FReportFile: TLazLoggerFileHandle;
57 FLogFileCreated, FReportFileCreated: Boolean;
58 FLogFileName, FReportFileName: String;
59 FLogBufferText: TStringList;
60 procedure InitLog;
61 procedure FinishLog;
62
GetCompilernull63 function GetCompiler: TTestDbgCompiler;
GetDebuggernull64 function GetDebugger: TTestDbgDebugger;
65 protected
66 FIgnoreReason: String;
67 // TestResults
68 procedure StartTestBlock;
69 procedure EndTestBlock;
70 procedure AddTestError (s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
71 procedure AddTestError (s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
72 procedure AddTestSuccess(s: string; MinDbgVers: Integer = 0; AIgnoreReason: String = '');
73 procedure AddTestSuccess(s: string; MinDbgVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
74 procedure ClearTestErrors;
75 procedure AssertTestErrors;
76 property TestErrors: string read FTestErrors;
77
78 // Logging
GetLogActivenull79 function GetLogActive: Boolean;
GetLogFileNamenull80 function GetLogFileName: String; virtual;
GetFinalLogFileNamenull81 function GetFinalLogFileName: String; virtual;
82 procedure CreateLog;
83 procedure CreateReport;
84 // Debugln
85 procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); virtual;
86 procedure DoDebugln(Sender: TObject; S: string; var Handled: Boolean); virtual;
87
88 procedure SetUp; override;
89 procedure TearDown; override;
90 procedure RunTest; override;
91 public
92 constructor Create; override;
93 destructor Destroy; override;
SkipTestnull94 function SkipTest: Boolean; virtual;
95 Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); overload;
96 Procedure TestCompile(const PrgName: string; out ExeName: string; const UsesDirs: array of TUsesDir;
97 NamePostFix: String=''; ExtraArgs: String=''); overload;
98 Procedure TestCompile(const Prg: TCommonSource; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); overload;
99 Procedure TestCompile(const Prg: TCommonSource; out ExeName: string; const UsesDirs: array of TUsesDir;
100 NamePostFix: String=''; ExtraArgs: String=''); overload;
101
102 // Logging
103 procedure LogText(const s: string; CopyToTestLogger: Boolean = False);
104 procedure LogError(const s: string; CopyToTestLogger: Boolean = False);
105
Matchesnull106 function Matches(RegEx, Val: string; ACaseSense: Boolean = False): Boolean;
107 // TestAsserts
TestMatchesnull108 function TestMatches(Expected, Got: string; ACaseSense: Boolean = False): Boolean;
TestMatchesnull109 function TestMatches(Name: string; Expected, Got: string; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestMatchesnull110 function TestMatches(Name: string; Expected, Got: string; ACaseSense: Boolean; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestMatchesnull111 function TestMatches(Name: string; Expected, Got: string; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
TestMatchesnull112 function TestMatches(Name: string; Expected, Got: string; ACaseSense: Boolean; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
113
TestEqualsnull114 function TestEquals(Expected, Got: string; ACaseSense: Boolean = False): Boolean;
TestEqualsnull115 function TestEquals(Name: string; Expected, Got: string; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestEqualsnull116 function TestEquals(Name: string; Expected, Got: string; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
117
TestEqualsnull118 function TestEquals(Name: string; Expected, Got: string; ACaseSense: Boolean; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestEqualsnull119 function TestEquals(Name: string; Expected, Got: string; ACaseSense: Boolean; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
120
TestEqualsnull121 function TestEquals(Expected, Got: integer): Boolean;
TestEqualsnull122 function TestEquals(Name: string; Expected, Got: integer; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestEqualsnull123 function TestEquals(Name: string; Expected, Got: integer; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
124
TestTruenull125 function TestTrue(Name: string; Got: Boolean; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestTruenull126 function TestTrue(Name: string; Got: Boolean; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
TestFalsenull127 function TestFalse(Name: string; Got: Boolean; MinDbgVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
TestFalsenull128 function TestFalse(Name: string; Got: Boolean; MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
129
130 procedure AssertDebuggerState(AState: TDBGState; AName: String = '');
131 procedure AssertDebuggerState(AStates: TDBGStates; AName: String = '');
132 procedure AssertDebuggerNotInErrorState;
133
134 property Parent: TDBGTestsuite read FParent;
135 property Compiler: TTestDbgCompiler read GetCompiler;
136 property Debugger: TTestDbgDebugger read GetDebugger;
137 // TestResults
138 property TestBaseName: String read FTestBaseName write FTestBaseName;
139 end;
140
141 TTestCaseClass = class of TDBGTestCase;
142
143 { TDBGTestWrapper }
144
145 TDBGTestWrapper = class(TDbgBaseTestsuite)
146 private
147 FParent: TDBGTestsuite;
148 public
149 constructor CreateTest(AParent: TDBGTestsuite; AClass: TClass); overload;
150 procedure AddTest(ATest: TTest); overload; override;
151 end;
152
153 { TDBGTestsuite }
154
155 TDBGTestsuite = class(TDbgBaseTestsuite)
156 private
157 FCompiler: TTestDbgCompiler;
158 FDebugger: TTestDbgDebugger;
159 public
160 constructor Create(ACompiler: TTestDbgCompiler; ADebugger: TTestDbgDebugger); overload;
161 procedure RegisterDbgTest(ATestClass: TTestCaseClass);
162
163 property Compiler: TTestDbgCompiler read FCompiler;
164 property Debugger: TTestDbgDebugger read FDebugger;
165 end;
166
167 TDBGTestsuiteClass = class of TDBGTestsuite;
168
169 procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes = []);
170
171 procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
172 ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
173
174 implementation
175
176 { TDbgBaseTestsuite }
177
178 procedure TDbgBaseTestsuite.LogOverviewReport;
179 var
180 oname: String;
181 FOview: TextFile;
182 begin
183 if FOverviewReport = '' then
184 exit;
185 if TestControlGetWriteOverView = wlAlways then begin
186 if DirectoryExistsUTF8(TestControlGetLogPath) then
187 oname := TestControlGetLogPath
188 else
189 oname := GetCurrentDirUTF8;
190
191 oname := oname + 'overview_' +
192 NameToFileName(DateTimeToStr(Now), False) +
193 '.txt';
194 AssignFile(FOView, oname);
195 Rewrite(FOView);
196 writeln(FOView, FOverviewReport);
197 CloseFile(FOView);
198 end;
199 FOverviewReport := '';
200 end;
201
202 procedure TDbgBaseTestsuite.Clear;
203 begin
204 //
205 end;
206
207 procedure TDbgBaseTestsuite.Run(AResult: TTestResult);
208 begin
209 inc(FInRun);
210 try
211 inherited Run(AResult);
212 finally
213 dec(FInRun);
214 if FInRun = 0 then begin
215 LogOverviewReport;
216 end;
217 Clear;
218 end;
219 end;
220
221 procedure TDbgBaseTestsuite.RunTest(ATest: TTest; AResult: TTestResult);
222 begin
223 inc(FInRun);
224 try
225 inherited RunTest(ATest, AResult);
226 finally
227 dec(FInRun);
228 if FInRun = 0 then begin
229 LogOverviewReport;
230 Clear;
231 end;
232 end;
233 end;
234
235 procedure TDbgBaseTestsuite.AddTest(ATest: TTest);
236 begin
237 inherited AddTest(ATest);
238 if ATest is TDbgBaseTestsuite then
239 TDbgBaseTestsuite(ATest).FDirectParent := Self
240 else
241 if ATest is TDBGTestCase then
242 TDBGTestCase(ATest).FDirectParent := Self;
243 end;
244
245 procedure TDbgBaseTestsuite.AddOverviewLog(const AText: String);
246 begin
247 if (FDirectParent <> nil) and (FDirectParent.FInRun > 0) then begin
248 FDirectParent.AddOverviewLog(AText);
249 exit;
250 end;
251 FOverviewReport := FOverviewReport + AText;
252 if (FInRun = 0) then
253 LogOverviewReport;
254 end;
255
256 { TDBGTestCase }
257
GetCompilernull258 function TDBGTestCase.GetCompiler: TTestDbgCompiler;
259 begin
260 Result := Parent.Compiler;
261 end;
262
TDBGTestCase.GetDebuggernull263 function TDBGTestCase.GetDebugger: TTestDbgDebugger;
264 begin
265 Result := Parent.Debugger;
266 end;
267
268 procedure TDBGTestCase.StartTestBlock;
269 begin
270 if FInTestBlock = 0 then begin
271 inc(FTestCnt);
272 FInTestBlockTxt := '';
273 FInTestBlockRes := tbOk;
274 end;
275 inc(FInTestBlock);
276 end;
277
278 procedure TDBGTestCase.EndTestBlock;
279 begin
280 dec(FInTestBlock);
281 if FInTestBlock = 0 then begin
282 case FInTestBlockRes of
283 tbErr: begin
284 FTestErrors := FTestErrors + FInTestBlockTxt;
285 inc(FTestErrorCnt);
286 end;
287 tbIgnore: begin
288 FIgnoredErrors := FIgnoredErrors + FInTestBlockTxt;
289 inc(FIgnoredErrorCnt);
290 end;
291 tbUnexpected: begin
292 FUnexpectedSuccess:= FUnexpectedSuccess + FInTestBlockTxt;
293 inc(FUnexpectedSuccessCnt);
294 end;
295 end;
296 FInTestBlockTxt := '';
297 FInTestBlockRes := tbOk;
298 end;
299 end;
300
301 procedure TDBGTestCase.AddTestError(s: string; MinDbgVers: Integer;
302 AIgnoreReason: String);
303 begin
304 AddTestError(s, MinDbgVers, 0, AIgnoreReason);
305 end;
306
307 procedure TDBGTestCase.AddTestError(s: string; MinDbgVers: Integer;
308 MinFpcVers: Integer; AIgnoreReason: String);
309 var
310 IgnoreReason: String;
311 i: Integer;
312 begin
313 if FInTestBlock = 0 then
314 inc(FTestCnt);
315 IgnoreReason := '';
316 s := FTestBaseName + s;
317 if MinDbgVers > 0 then begin
318 i := Debugger.Version;
319 if (i > 0) and (i < MinDbgVers) then
320 IgnoreReason := 'GDB ('+IntToStr(i)+') to old, required:'+IntToStr(MinDbgVers);
321 end;
322 if MinFpcVers > 0 then begin
323 i := Compiler.Version;
324 if (i > 0) and (i < MinFpcVers) then
325 IgnoreReason := 'FPC ('+IntToStr(i)+') to old, required:'+IntToStr(MinFpcVers);
326 end;
327 IgnoreReason := IgnoreReason + AIgnoreReason;
328 if IgnoreReason = '' then
329 IgnoreReason := FIgnoreReason;
330
331 if FInTestBlock > 0 then begin
332 if IgnoreReason <> '' then begin
333 FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
334 if FInTestBlockRes in [tbOk, tbUnexpected] then
335 FInTestBlockRes := tbIgnore;
336 end else begin
337 FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + s + LineEnding;
338 FInTestBlockRes := tbErr;
339 DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]);
340 end;
341 end
342 else begin
343 if IgnoreReason <> '' then begin
344 FIgnoredErrors := FIgnoredErrors + IntToStr(FTestCnt) + ': ' + '### '+IgnoreReason +' >>> '+s+LineEnding;
345 inc(FIgnoredErrorCnt);
346 end else begin
347 FTestErrors := FTestErrors + IntToStr(FTestCnt) + ': ' + s + LineEnding;
348 DebugLn(['!!!!! ERROR: ' + IntToStr(FTestCnt) + ': ' + s]);
349 inc(FTestErrorCnt);
350 end;
351 end;
352 end;
353
354 procedure TDBGTestCase.AddTestSuccess(s: string; MinDbgVers: Integer;
355 AIgnoreReason: String);
356 begin
357 AddTestSuccess(s, MinDbgVers, 0, AIgnoreReason);
358 end;
359
360 procedure TDBGTestCase.AddTestSuccess(s: string; MinDbgVers: Integer;
361 MinFpcVers: Integer; AIgnoreReason: String);
362 var
363 i: Integer;
364 begin
365 s := FTestBaseName + s;
366 if FInTestBlock = 0 then
367 inc(FTestCnt);
368 if (MinDbgVers > 0) then begin
369 i := Debugger.Version;
370 if (i > 0) and (i < MinDbgVers) then
371 AIgnoreReason := AIgnoreReason
372 + 'GDB ('+IntToStr(i)+') to old, required:'+IntToStr(MinDbgVers);
373 end;
374 if (MinFpcVers > 0) then begin
375 i := Compiler.Version;
376 if (i > 0) and (i < MinFpcVers) then
377 AIgnoreReason := AIgnoreReason
378 + 'FPC ('+IntToStr(i)+') to old, required:'+IntToStr(MinFpcVers);
379 end;
380
381 if AIgnoreReason <> '' then begin
382 s := '[OK] ' + s;
383 if FInTestBlock > 0 then begin
384 FInTestBlockTxt := FInTestBlockTxt + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding;
385 if FInTestBlockRes in [tbOk] then
386 FInTestBlockRes := tbUnexpected;
387 end
388 else begin
389 FUnexpectedSuccess:= FUnexpectedSuccess + IntToStr(FTestCnt) + ': ' + '### '+AIgnoreReason +' >>> '+s+LineEnding;
390 inc(FUnexpectedSuccessCnt);
391 end;
392 end
393 else
394 inc(FSucessCnt);
395 end;
396
397 procedure TDBGTestCase.ClearTestErrors;
398 begin
399 FTotalErrorCnt := FTotalErrorCnt + FTestErrorCnt;
400 FTotalIgnoredErrorCnt := FTotalIgnoredErrorCnt + FIgnoredErrorCnt;
401 FTotalUnexpectedSuccessCnt := FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt;
402
403 FTestErrors := '';
404 FIgnoredErrors := '';
405 FUnexpectedSuccess := '';
406 FTestErrorCnt := 0;
407 FIgnoredErrorCnt := 0;
408 FUnexpectedSuccessCnt := 0;
409 FSucessCnt := 0;
410 FTestCnt := 0;
411 FTestBaseName := '';
412 end;
413
414 procedure TDBGTestCase.AssertTestErrors;
415
RemoveHexNumbersnull416 function RemoveHexNumbers(txt: String): String;
417 var
418 i, j, n: Integer;
419 p, p2: SizeInt;
420 s: String;
421 begin
422 Result := txt;
423 i := 1;
424 j := 1;
425 n := 0;
426 p := PosEx('$', Result, i);
427 while p > 0 do begin
428 if p > n then j := 1;
429 n := PosSetEx([#10,#13], Result, p);
430 i := p+2;
431
432 p2 := p + 2;
433 while (p2 <= Length(Result)) and (Result[p2] in ['0'..'9', 'a'..'f', 'A'..'F']) do
434 inc(p2);
435 if p2 - p > 6 then begin
436 s := copy(Result, p, p2-p);
437 Result := StringReplace(Result, s, '$##HEX'+IntToStr(j)+'##', [rfReplaceAll, rfIgnoreCase]);
438 inc(j);
439 end;
440
441 p := PosEx('$', Result, i);
442 end;
443 end;
444
445 var
446 s, s1: String;
447 begin
448 s := FTestErrors;
449 s1 := Format('Failed: %4d of %5d - Ignored: %5d Unexpected: %4d - Success: %5d',
450 [FTestErrorCnt, FTestCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt ]);
451 FDirectParent.AddOverviewLog(Format('%-30s %14s %12s %7s %18s %s',
452 [TestName, Compiler.Name, SymbolTypeNames[Compiler.SymbolType],
453 CpuBitNames[Compiler.CpuBitType], Debugger.Name,
454 s1 + LineEnding]));
455 FTestErrors := '';
456 if GetLogActive or (FTestErrorCnt > 0) or (s <> '') then begin
457 LogError('***' + s1 + '***' +LineEnding);
458 LogError('================= Failed:'+LineEnding);
459 LogError(s);
460 LogError('================= Ignored'+LineEnding);
461 LogError(FIgnoredErrors);
462 LogError('================= Unexpected Success'+LineEnding);
463 LogError(FUnexpectedSuccess);
464 LogError('================='+LineEnding);
465 end;
466 if (TestControlGetWriteReport = wlAlways) or
467 ( (TestControlGetWriteReport = wlOnError) and (
468 (FTestErrorCnt > 0) or (FIgnoredErrorCnt > 0) or (FUnexpectedSuccessCnt > 0)
469 ))
470 then begin
471 CreateReport;
472 FReportFile.WriteLnToFile('***' + s1 + '***' +LineEnding);
473 FReportFile.WriteLnToFile('================= Failed:'+LineEnding);
474 FReportFile.WriteLnToFile(RemoveHexNumbers(s));
475 FReportFile.WriteLnToFile('================= Ignored'+LineEnding);
476 FReportFile.WriteLnToFile(RemoveHexNumbers(FIgnoredErrors));
477 FReportFile.WriteLnToFile('================= Unexpected Success'+LineEnding);
478 FReportFile.WriteLnToFile(RemoveHexNumbers(FUnexpectedSuccess));
479 FReportFile.WriteLnToFile('================='+LineEnding);
480 end;
481
482 FIgnoredErrors := '';
483 FUnexpectedSuccess := '';
484 if s <> '' then
485 Fail(s1+ LineEnding + s);
486 end;
487
TestMatchesnull488 function TDBGTestCase.TestMatches(Expected, Got: string; ACaseSense: Boolean
489 ): Boolean;
490 begin
491 Result := TestMatches('', Expected, Got, ACaseSense, 0, 0);
492 end;
493
TestMatchesnull494 function TDBGTestCase.TestMatches(Name: string; Expected, Got: string;
495 MinDbgVers: Integer; AIgnoreReason: String): Boolean;
496 begin
497 Result := TestMatches(Name, Expected, Got, MinDbgVers, 0, AIgnoreReason);
498 end;
499
TestMatchesnull500 function TDBGTestCase.TestMatches(Name: string; Expected, Got: string;
501 ACaseSense: Boolean; MinDbgVers: Integer; AIgnoreReason: String): Boolean;
502 begin
503 Result := TestMatches(Name, Expected, Got, ACaseSense, MinDbgVers);
504 end;
505
TestMatchesnull506 function TDBGTestCase.TestMatches(Name: string; Expected, Got: string;
507 MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
508 begin
509 Result := TestMatches(Name, Expected, Got, False, MinDbgVers, MinFpcVers, AIgnoreReason);
510 end;
511
TestMatchesnull512 function TDBGTestCase.TestMatches(Name: string; Expected, Got: string;
513 ACaseSense: Boolean; MinDbgVers: Integer; MinFpcVers: Integer;
514 AIgnoreReason: String): Boolean;
515 begin
516 if FRegX = nil then
517 FRegX := TRegExpr.Create;
518 FRegX.ModifierI := not ACaseSense;
519 FRegX.Expression := Expected;
520 Result := FRegX.Exec(Got);
521 Name := Name + ': Expected (regex) "'+Expected+'", Got "'+Got+'"';
522 if Result
523 then AddTestSuccess(Name, MinDbgVers, MinFpcVers, AIgnoreReason)
524 else AddTestError(Name, MinDbgVers, MinFpcVers, AIgnoreReason);
525 end;
526
TestEqualsnull527 function TDBGTestCase.TestEquals(Expected, Got: string; ACaseSense: Boolean
528 ): Boolean;
529 begin
530 Result := TestEquals('', Expected, Got, ACaseSense);
531 end;
532
TestEqualsnull533 function TDBGTestCase.TestEquals(Name: string; Expected, Got: string;
534 MinDbgVers: Integer; AIgnoreReason: String): Boolean;
535 begin
536 Result := TestEquals(Name, Expected, Got, MinDbgVers, 0, AIgnoreReason);
537 end;
538
TestEqualsnull539 function TDBGTestCase.TestEquals(Name: string; Expected, Got: string;
540 MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
541 begin
542 Result := Got = Expected;
543 Name := Name + ': Expected "'+Expected+'", Got "'+Got+'"';
544 if Result
545 then AddTestSuccess(Name, MinDbgVers, MinFpcVers, AIgnoreReason)
546 else AddTestError(Name, MinDbgVers, MinFpcVers, AIgnoreReason);
547 end;
548
TestEqualsnull549 function TDBGTestCase.TestEquals(Name: string; Expected, Got: string;
550 ACaseSense: Boolean; MinDbgVers: Integer; AIgnoreReason: String): Boolean;
551 begin
552 Result := TestEquals(Name, Expected, Got, ACaseSense, MinDbgVers, 0, AIgnoreReason);
553 end;
554
TestEqualsnull555 function TDBGTestCase.TestEquals(Name: string; Expected, Got: string;
556 ACaseSense: Boolean; MinDbgVers: Integer; MinFpcVers: Integer;
557 AIgnoreReason: String): Boolean;
558 begin
559 if ACaseSense then
560 Result := Got = Expected
561 else
562 Result := UpperCase(Got) = UpperCase(Expected);
563 Name := Name + ': Expected "'+Expected+'", Got "'+Got+'"';
564 if Result
565 then AddTestSuccess(Name, MinDbgVers, MinFpcVers, AIgnoreReason)
566 else AddTestError(Name, MinDbgVers, MinFpcVers, AIgnoreReason);
567 end;
568
TestEqualsnull569 function TDBGTestCase.TestEquals(Expected, Got: integer): Boolean;
570 begin
571 Result := TestEquals('', Expected, Got);
572 end;
573
TestEqualsnull574 function TDBGTestCase.TestEquals(Name: string; Expected, Got: integer;
575 MinDbgVers: Integer; AIgnoreReason: String): Boolean;
576 begin
577 Result := TestEquals(Name, Expected, Got, MinDbgVers, 0, AIgnoreReason);
578 end;
579
TestEqualsnull580 function TDBGTestCase.TestEquals(Name: string; Expected, Got: integer;
581 MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
582 begin
583 Result := Got = Expected;
584 Name := Name + ': Expected "'+IntToStr(Expected)+'", Got "'+IntToStr(Got)+'"';
585 if Result
586 then AddTestSuccess(Name, MinDbgVers, MinFpcVers, AIgnoreReason)
587 else AddTestError(Name, MinDbgVers, MinFpcVers, AIgnoreReason);
588 end;
589
TDBGTestCase.TestTruenull590 function TDBGTestCase.TestTrue(Name: string; Got: Boolean; MinDbgVers: Integer;
591 AIgnoreReason: String): Boolean;
592 begin
593 Result := TestTrue(Name, Got, MinDbgVers, 0, AIgnoreReason);
594 end;
595
TDBGTestCase.TestTruenull596 function TDBGTestCase.TestTrue(Name: string; Got: Boolean; MinDbgVers: Integer;
597 MinFpcVers: Integer; AIgnoreReason: String): Boolean;
598 begin
599 Result := Got;
600 if Result
601 then AddTestSuccess(Name + ': Got "True"', MinDbgVers, MinFpcVers, AIgnoreReason)
602 else AddTestError(Name + ': Expected "True", Got "False"', MinDbgVers, MinFpcVers, AIgnoreReason);
603 end;
604
TestFalsenull605 function TDBGTestCase.TestFalse(Name: string; Got: Boolean;
606 MinDbgVers: Integer; AIgnoreReason: String): Boolean;
607 begin
608 Result := TestFalse(Name, Got, MinDbgVers, 0, AIgnoreReason);
609 end;
610
TestFalsenull611 function TDBGTestCase.TestFalse(Name: string; Got: Boolean;
612 MinDbgVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
613 begin
614 Result := not Got;
615 if Result
616 then AddTestSuccess(Name + ': Got "False"', MinDbgVers, MinFpcVers, AIgnoreReason)
617 else AddTestError(Name + ': Expected "False", Got "True"', MinDbgVers, MinFpcVers, AIgnoreReason);
618 end;
619
620 procedure TDBGTestCase.AssertDebuggerState(AState: TDBGState; AName: String);
621 begin
622 if not TestEquals('Debugger State '+AName, dbgs(AState), dbgs(Debugger.LazDebugger.State)) then
623 AssertTestErrors;
624 end;
625
626 procedure TDBGTestCase.AssertDebuggerState(AStates: TDBGStates; AName: String);
627 begin
628 If not (Debugger.LazDebugger.State in AStates) then begin
629 TestTrue('Debugger State not in expected, got: ' + dbgs(Debugger.LazDebugger.State) + ' ' +AName, False);
630 AssertTestErrors;
631 end;
632 end;
633
634 procedure TDBGTestCase.AssertDebuggerNotInErrorState;
635 begin
636 If (Debugger.LazDebugger.State = dsError) then begin
637 TestTrue('Debugger State should not be dsError', False);
638 AssertTestErrors;
639 end;
640 end;
641
TDBGTestCase.GetLogActivenull642 function TDBGTestCase.GetLogActive: Boolean;
643 begin
644 Result := (TestControlGetWriteLog = wlAlways) or FLogFileCreated;
645 end;
646
TDBGTestCase.GetLogFileNamenull647 function TDBGTestCase.GetLogFileName: String;
648 begin
649 Result := TestName
650 + '_' + NameToFileName(Compiler.Name, False)
651 + '_' + SymbolTypeNames[Compiler.SymbolType]
652 + '_' + CpuBitNames[Compiler.CpuBitType]
653 + '_' + NameToFileName(Debugger.Name, False)
654 ; // .log extension will be added
655 end;
656
TDBGTestCase.GetFinalLogFileNamenull657 function TDBGTestCase.GetFinalLogFileName: String;
658 begin
659 Result := FLogFileName;
660
661 if (FTotalIgnoredErrorCnt + FIgnoredErrorCnt > 0)
662 then Result := Result + '___ignor.'+IntToStr(FTotalIgnoredErrorCnt + FIgnoredErrorCnt);
663 if (FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt > 0)
664 then Result := Result + '___unexp.'+IntToStr(FTotalUnexpectedSuccessCnt + FUnexpectedSuccessCnt);
665 if (FTotalErrorCnt + FTestErrorCnt > 0)
666 then Result := Result + '___fail.'+IntToStr(FTotalErrorCnt + FTestErrorCnt);
667 end;
668
669 procedure TDBGTestCase.InitLog;
670 begin
671 FLogFileCreated := False;
672 FLogBufferText.Clear;
673 end;
674
675 procedure TDBGTestCase.CreateLog;
676 var
677 name: String;
678 i: Integer;
679 dir: String;
680 begin
681 if FLogFileCreated then exit;
682 EnterCriticalsection(FLogLock);
683 try
684 if FLogFileCreated then exit;
685
686 name := GetLogFileName;
687 for i := 1 to length(name) do
688 if name[i] in ['/', '\', '*', '?', ':'] then
689 name[i] := '_';
690
691 if DirectoryExistsUTF8(TestControlGetLogPath) then
692 dir := TestControlGetLogPath
693 else
694 dir := GetCurrentDirUTF8;
695
696 FLogFileName := dir + name;
697
698 {$IFDEF Windows}
699 FLogFile := TLazLoggerFileHandleThreadSave.Create;
700 {$ELSE}
701 FLogFile := TLazLoggerFileHandleMainThread.Create;
702 {$ENDIF}
703 FLogFile.LogName := FLogFileName + '.log.running';
704 //AssignFile(FLogFile, FLogFileName + '.log.running');
705 //Rewrite(FLogFile);
706 FLogFileCreated := True;
707
708 FLogFile.WriteLnToFile(FLogBufferText.Text);
709 //writeln(FLogFile, FLogBufferText);
710 FLogBufferText.Clear;
711 finally
712 LeaveCriticalsection(FLogLock);
713 end;
714 end;
715
716 procedure TDBGTestCase.CreateReport;
717 var
718 name: String;
719 i: Integer;
720 dir: String;
721 begin
722 if FReportFileCreated then exit;
723 EnterCriticalsection(FLogLock);
724 try
725 if FReportFileCreated then exit;
726
727 name := GetLogFileName;
728 for i := 1 to length(name) do
729 if name[i] in ['/', '\', '*', '?', ':'] then
730 name[i] := '_';
731
732 if DirectoryExistsUTF8(TestControlGetLogPath) then
733 dir := TestControlGetLogPath
734 else
735 dir := GetCurrentDirUTF8;
736
737 FReportFileName := dir + name;
738
739 {$IFDEF Windows}
740 FReportFile := TLazLoggerFileHandleThreadSave.Create;
741 {$ELSE}
742 FReportFile := TLazLoggerFileHandleMainThread.Create;
743 {$ENDIF}
744 FReportFile.LogName := FReportFileName + '___fail.' + IntToStr(FTestErrorCnt) + '.report';
745 //AssignFile(FReportFile, FReportFileName + '.log.running');
746 //Rewrite(FReportFile);
747 FReportFileCreated := True;
748
749 finally
750 LeaveCriticalsection(FLogLock);
751 end;
752 end;
753
754 procedure TDBGTestCase.FinishLog;
755 var
756 NewName: String;
757 begin
758 if FLogFileCreated then begin
759 CheckSynchronize(1);
760 FreeAndNil(FLogFile);
761 //CloseFile(FLogFile);
762 NewName := GetFinalLogFileName;
763 sleep(5);
764 RenameFileUTF8(FLogFileName + '.log.running', NewName + '.log');
765 end;
766 if FReportFileCreated then begin
767 CheckSynchronize(1);
768 FreeAndNil(FReportFile);
769 //CloseFile(FReportFile);
770 FReportFileCreated := False;
771 end;
772 FLogBufferText.Clear;
773 end;
774
EscapeTextnull775 function EscapeText(s: String): String;
776 begin
777 Result := s;
778 Result := StringReplace(Result, #0, '\\x00', [rfReplaceAll]);
779 end;
780
781 procedure TDBGTestCase.LogText(const s: string; CopyToTestLogger: Boolean);
782 begin
783 if GetLogActive then begin
784 CreateLog;
785 FLogFile.WriteLnToFile(EscapeText(s));
786 //writeln(FLogFile, EscapeText(s));
787 end
788 else begin
789 EnterCriticalsection(FLogLock);
790 try
791 if FLogBufferText.Count > 500000 then
792 FLogBufferText.Delete(1);
793 FLogBufferText.Add(EscapeText(s));
794 finally
795 LeaveCriticalsection(FLogLock);
796 end;
797 end;
798 if CopyToTestLogger then
799 TestLogger.DebugLn(s);
800 end;
801
802 procedure TDBGTestCase.LogError(const s: string; CopyToTestLogger: Boolean);
803 begin
804 if GetLogActive or (TestControlGetWriteLog = wlOnError) then begin
805 CreateLog;
806 FLogFile.WriteLnToFile(EscapeText(s));
807 //writeln(FLogFile, EscapeText(s));
808 end;
809 if CopyToTestLogger then
810 TestLogger.DebugLn(s);
811 end;
812
Matchesnull813 function TDBGTestCase.Matches(RegEx, Val: string; ACaseSense: Boolean): Boolean;
814 begin
815 if FRegX = nil then
816 FRegX := TRegExpr.Create;
817 FRegX.ModifierI := not ACaseSense;
818 FRegX.Expression := RegEx;
819 Result := FRegX.Exec(Val);
820 end;
821
822 procedure TDBGTestCase.DoDbgOut(Sender: TObject; S: string; var Handled: Boolean
823 );
824 begin
825 LogText(': ' + S);
826 Handled := True;
827 end;
828
829 procedure TDBGTestCase.DoDebugln(Sender: TObject; S: string;
830 var Handled: Boolean);
831 begin
832 LogText(S);
833 Handled := True;
834 end;
835
836 procedure TDBGTestCase.SetUp;
837 var
838 i: Integer;
839 begin
840 InitCriticalSection(FLogLock);
841 ClearTestErrors;
842 FTotalErrorCnt := 0;
843 FTotalIgnoredErrorCnt := 0;
844 FTotalUnexpectedSuccessCnt := 0;
845 FIgnoreReason := '';
846
847 for i := 0 to DebugLogger.LogGroupList.Count - 1 do
848 DebugLogger.LogGroupList[i]^.Enabled := True;
849
850 InitLog;
851 DebugLogger.OnDbgOut := @DoDbgOut;
852 DebugLogger.OnDebugLn := @DoDebugln;
853 inherited SetUp;
854 end;
855
856 procedure TDBGTestCase.TearDown;
857 begin
858 inherited TearDown;
859 DebugLogger.OnDbgOut := nil;
860 DebugLogger.OnDebugLn := nil;
861 FinishLog;
862 FreeAndNil(FRegX);
863 DoneCriticalsection(FLogLock);
864 end;
865
866 procedure TDBGTestCase.RunTest;
867 begin
868 TestLogger.DebugLn(['Running ', Parent.TestSuiteName, ' ', Parent.TestName, ' ', TestSuiteName, ' ', TestName]);
869 try
870 ClearTestErrors;
871 inherited RunTest;
872 finally
873 Debugger.CleanAfterTestDone;
874 end;
875 end;
876
877 constructor TDBGTestCase.Create;
878 begin
879 inherited Create;
880 FLogBufferText := TStringList.Create;
881 end;
882
883 destructor TDBGTestCase.Destroy;
884 begin
885 FreeAndNil(FLogBufferText);
886 inherited Destroy;
887 end;
888
TDBGTestCase.SkipTestnull889 function TDBGTestCase.SkipTest: Boolean;
890 begin
891 Result := not(
892 TestControlCanCompiler(Parent.Compiler.Name) and
893 TestControlCanDebugger(Parent.Debugger.Name) and
894 TestControlCanSymType(Parent.Compiler.SymbolType) and
895 TestControlCanCpuBits(Parent.Compiler.CpuBitType)
896 );
897 end;
898
899 procedure TDBGTestCase.TestCompile(const PrgName: string; out ExeName: string;
900 NamePostFix: String; ExtraArgs: String);
901 begin
902 TestCompile(PrgName, ExeName, [], NamePostFix, ExtraArgs);
903 end;
904
905 procedure TDBGTestCase.TestCompile(const PrgName: string; out ExeName: string;
906 const UsesDirs: array of TUsesDir; NamePostFix: String; ExtraArgs: String);
907 begin
908 try
909 LogText(LineEnding+LineEnding + '******************* compile '+PrgName + ' ' + ExtraArgs +LineEnding );
910 Compiler.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs);
911 LogText(Compiler.LastCompileCommandLine+LineEnding + '*******************' +LineEnding+LineEnding );
912 except
913 On E: Exception do begin
914 TestTrue('Compile '+PrgName + ' GOT: '+ E.Message+ LineEnding + Compiler.LastCompileOutput, False);
915 AssertTestErrors;
916 end;
917 end;
918 end;
919
920 procedure TDBGTestCase.TestCompile(const Prg: TCommonSource; out
921 ExeName: string; NamePostFix: String; ExtraArgs: String);
922 begin
923 TestCompile(Prg, ExeName, [], NamePostFix, ExtraArgs);
924 end;
925
926 procedure TDBGTestCase.TestCompile(const Prg: TCommonSource; out
927 ExeName: string; const UsesDirs: array of TUsesDir; NamePostFix: String;
928 ExtraArgs: String);
929 begin
930 Prg.Save(AppDir);
931 TestCompile(Prg.FullFileName, ExeName, UsesDirs, NamePostFix, ExtraArgs);
932 end;
933
934 { TDBGTestWrapper }
935
936 constructor TDBGTestWrapper.CreateTest(AParent: TDBGTestsuite; AClass: TClass);
937 begin
938 FParent := AParent;
939 Create(AClass);
940 end;
941
942 procedure TDBGTestWrapper.AddTest(ATest: TTest);
943 begin
944 if ATest is TDBGTestCase then
945 TDBGTestCase(ATest).FParent := FParent;
946 inherited AddTest(ATest);
947 end;
948
949 { TDBGTestsuite }
950
951 constructor TDBGTestsuite.Create(ACompiler: TTestDbgCompiler;
952 ADebugger: TTestDbgDebugger);
953 begin
954 FCompiler := ACompiler;
955 FDebugger := ADebugger;
956 inherited Create(ACompiler.FullName + ', ' + ADebugger.FullName);
957 end;
958
959 procedure TDBGTestsuite.RegisterDbgTest(ATestClass: TTestCaseClass);
960 var
961 NewSuite: TDBGTestWrapper;
962 begin
963 NewSuite := TDBGTestWrapper.CreateTest(Self, ATestClass);
964 AddTest(NewSuite);
965 end;
966
967 var
968 MainTestSuite: TDbgBaseTestsuite;
969
970 procedure RegisterDbgTest(ATestClass: TTestCaseClass; ASymTypes: TSymbolTypes);
971 var
972 Suite: TTestSuite;
973 i: Integer;
974 begin
975 //Suite := GetTestRegistry;
976 Suite := MainTestSuite;
977 for i := 0 to Suite.ChildTestCount - 1 do
978 if Suite.Test[i] is TDBGTestsuite then
979 if (ASymTypes = []) or (TDBGTestsuite(Suite.Test[i]).Compiler.SymbolType in ASymTypes) then
980 TDBGTestsuite(Suite.Test[i]).RegisterDbgTest(ATestClass);
981 end;
982
983 procedure CreateTestSuites(ACompilerList: TTestDbgCompilerList;
984 ADebuggerList: TTestDbgDebuggerList; ATestSuiteClass: TDBGTestsuiteClass);
985 var
986 i, j: Integer;
987 begin
988 MainTestSuite := TDbgBaseTestsuite.Create;
989 GetTestRegistry.AddTest(MainTestSuite);
990 for i := 0 to ACompilerList.Count - 1 do
991 for j := 0 to ADebuggerList.Count - 1 do begin
992 if ADebuggerList[j].MatchesCompiler(ACompilerList[i]) then begin
993 MainTestSuite.AddTest(ATestSuiteClass.Create(ACompilerList[i], ADebuggerList[j]));
994 end;
995 end;
996 end;
997
998 end.
999
1000