1 unit TestBase;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, FileUtil, fpcunit, testregistry, LCLProc,
9 LazLogger, LazFileUtils, DbgIntfDebuggerBase, Dialogs, Forms, RegExpr,
10 GDBMIDebugger, TestDbgConfig, TestDbgTestSuites, TTestDbgExecuteables,
11 TTestDebuggerClasses, TestDbgCompilerProcess, TestDbgControl, TestOutputLogger; // , FpGdbmiDebugger;
12 // EnvironmentOpts, ExtToolDialog, TransferMacros,
13
14
15 const
16
17 stDwarf2All = [stDwarf, stDwarfSet];
18 stDwarfAll = [stDwarf, stDwarfSet, stDwarf3];
19 stSymAll = [stStabs, stDwarf, stDwarfSet, stDwarf3];
20
21 TWatchDisplayFormatNames: array [TWatchDisplayFormat] of string =
22 ('wdfDefault',
23 'wdfStructure',
24 'wdfChar', 'wdfString',
25 'wdfDecimal', 'wdfUnsigned', 'wdfFloat', 'wdfHex',
26 'wdfPointer',
27 'wdfMemDump', 'wdfBinary'
28 );
29
30 type
31
32 TGDBMIDebuggerClass = class of TGDBMIDebugger;
33
34 { TTestDebuggerHelper }
35
36 TTestDebuggerHelper = class helper for TDebuggerIntf
37 procedure AddTestBreakPoint(AFilename: String; ALine: Integer; AEnabled: Boolean = True);
38 end;
39
40
41 TDebuggerInfo = TExternalExeInfo;
42 TCompilerInfo = TExternalExeInfo;
43 { TCompilerList }
44
45 TCompilerList = class(TBaseList)
46 private
GetCompilerInfonull47 function GetCompilerInfo(Index: Integer): TCompilerInfo;
48 public
49 property CompilerInfo[Index: Integer]: TCompilerInfo read GetCompilerInfo;
50 end;
51
52 { TDebuggerList }
53
54 TDebuggerList = class(TBaseList)
55 private
GetDebuggerInfonull56 function GetDebuggerInfo(Index: Integer): TDebuggerInfo;
57 public
58 property DebuggerInfo[Index: Integer]: TDebuggerInfo read GetDebuggerInfo;
59 end;
60
61 { TCompilerSuite }
62
63 TCompilerSuite = class(TDBGTestsuite)
64 private
65 FSymbolSwitch: String;
66 FFileNameExt: String;
67 FCompileProcess: TCompilerProcess;
GetCompilerInfonull68 function GetCompilerInfo: TExternalExeInfo;
GetDebuggerInfonull69 function GetDebuggerInfo: TExternalExeInfo;
GetSymbolTypenull70 function GetSymbolType: TSymbolType;
71 protected
72 public
73 constructor Create; reintroduce; overload; override;
74 public
75 property SymbolType: TSymbolType read GetSymbolType;
76 property SymbolSwitch: String read FSymbolSwitch;
77
78 property CompilerInfo: TExternalExeInfo read GetCompilerInfo;
79 property DebuggerInfo: TExternalExeInfo read GetDebuggerInfo;
80 end;
81
82 { TGDBMIDebuggerForTest }
83 var
84 FEvalDone: Boolean;
85 FEvalRes: String;
86 FEvalResType: TDBGType;
87
88 type
89
90 TGDBMIDebuggerForTest = class helper for TGDBMIDebugger
91 private
92 procedure EvalCallBack(Sender: TObject; ASuccess: Boolean;
93 ResultText: String; ResultDBGType: TDBGType);
94 public
EvaluateWaitnull95 function EvaluateWait(const AExpression: String; var ARes: String;
96 var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags = []; ATimeOut: Integer = -1): Boolean;
97 end;
98
99
100 { TGDBTestCase }
101
102 TGDBTestCase = class(TDBGTestCase)
103 private
104 FTotalGDBInternalErrorCnt, FTotalDsErrorCrash: Integer;
105 FTotalClassVsRecord: Integer;
106 FStartTime: QWord;
107 FLogDebuglnCount: Integer;
GetCompilerInfonull108 function GetCompilerInfo: TCompilerInfo;
GetSymbolTypenull109 function GetSymbolType: TSymbolType;
110 procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); override;
111 procedure DoDebugln(Sender: TObject; S: string; var Handled: Boolean); override;
GetWatchesnull112 function GetWatches: TTestWatchesMonitor;
113 protected
114 procedure SetUp; override;
GetFinalLogFileNamenull115 function GetFinalLogFileName: String; override;
116 procedure DoDbgOutPut(Sender: TObject; const AText: String); virtual;
117 procedure InternalDbgOutPut(Sender: TObject; const AText: String);
InternalFeedBacknull118 function InternalFeedBack(Sender: TObject; const AText, AInfo: String;
119 AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
120 procedure InternalDbgEvent(Sender: TObject;
121 const ACategory: TDBGEventCategory; const AEventType: TDBGEventType;
122 const AText: String);
GdbClassnull123 function GdbClass: TGDBMIDebuggerClass; virtual;
StartGDBnull124 function StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;
125 procedure CleanGdb;
126
GetDebuggerInfonull127 function GetDebuggerInfo: TDebuggerInfo;
128
129 property TotalClassVsRecord: Integer read FTotalClassVsRecord write FTotalClassVsRecord;
130 property TotalDsErrorCrash: Integer read FTotalDsErrorCrash write FTotalDsErrorCrash;
131 public
132 procedure LogToFile(const s: string);
133 public
134 property DebuggerInfo: TDebuggerInfo read GetDebuggerInfo;
135 property SymbolType: TSymbolType read GetSymbolType;
136 property CompilerInfo: TCompilerInfo read GetCompilerInfo;
137 public
138 property Watches: TTestWatchesMonitor read GetWatches;
139 end;
140
141
GetCompilersnull142 function GetCompilers: TCompilerList;
GetDebuggersnull143 function GetDebuggers: TDebuggerList;
144
145 var
146 TestGdbClass: TGDBMIDebuggerClass = TGDBMIDebugger;
147 // TestGdbClass: TGDBMIDebuggerClass = TFPGDBMIDebugger;
148
149
150 implementation
151
152 var
153 Compilers: TCompilerList = nil;
154 Debuggers: TDebuggerList = nil;
155
156
GetCompilersnull157 function GetCompilers: TCompilerList;
158 begin
159 if Compilers <> nil then exit(Compilers);
160 Compilers := TCompilerList(LoadConfig(ConfDir + 'fpclist.txt'));
161 Result := Compilers;
162 end;
163
GetDebuggersnull164 function GetDebuggers: TDebuggerList;
165 begin
166 if Debuggers <> nil then exit(Debuggers);
167 Debuggers := TDebuggerList(LoadConfig(ConfDir + 'gdblist.txt'));
168 Result := Debuggers;
169 end;
170
171 { TTestDebuggerHelper }
172
173 procedure TTestDebuggerHelper.AddTestBreakPoint(AFilename: String;
174 ALine: Integer; AEnabled: Boolean);
175 begin
176 with BreakPoints.Add(AFilename, ALine, True) do begin
177 Enabled := AEnabled;
178 InitialEnabled := AEnabled;
179 EndUpdate;
180 end;
181 end;
182
183 { TGDBMIDebuggerForTest }
184
185 procedure TGDBMIDebuggerForTest.EvalCallBack(Sender: TObject;
186 ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
187 begin
188 FEvalRes := ResultText;
189 FEvalResType := ResultDBGType;
190 FEvalDone := true;
191 end;
192
EvaluateWaitnull193 function TGDBMIDebuggerForTest.EvaluateWait(const AExpression: String;
194 var ARes: String; var AResType: TDBGType; EvalFlags: TDBGEvaluateFlags;
195 ATimeOut: Integer): Boolean;
196 var
197 t: QWord;
198 begin
199 FEvalResType := nil;
200 FEvalDone := false;
201 t := GetTickCount64;
202 inherited Evaluate(AExpression, @EvalCallBack, EvalFlags);
203 while not FEvalDone do begin
204 Application.ProcessMessages;
205 sleep(5);
206 if ATimeOut > 0 then begin
207 if GetTickCount64 - t > ATimeOut then
208 break;
209 end;
210 end;
211 ARes := FEvalRes;
212 AResType := FEvalResType;
213 end;
214
215 { TGDBTestCase }
216
217 procedure TGDBTestCase.DoDbgOutPut(Sender: TObject; const AText: String);
218 begin
219 //
220 end;
221
222 procedure TGDBTestCase.InternalDbgOutPut(Sender: TObject; const AText: String);
223 begin
224 //LogToFile(AText);
225 DoDbgOutPut(Sender, AText);
226 end;
227
GdbClassnull228 function TGDBTestCase.GdbClass: TGDBMIDebuggerClass;
229 begin
230 Result := TestGdbClass;
231 end;
232
233 procedure TGDBTestCase.DoDbgOut(Sender: TObject; S: string; var Handled: Boolean);
234 begin
235 DoDebugln(Sender, '| '+S, Handled);
236 end;
237
238 procedure TGDBTestCase.DoDebugln(Sender: TObject; S: string; var Handled: Boolean);
239 begin
240 inherited DoDebugln(Sender, S, Handled);
241
242 if pos('(gdb)', s) > 0 then begin
243 inc(FLogDebuglnCount);
244 if FLogDebuglnCount mod 10 = 0 then begin
245 TestLogger.DebugLn([FLogDebuglnCount]);
246 end;
247 end;
248 end;
249
TGDBTestCase.GetWatchesnull250 function TGDBTestCase.GetWatches: TTestWatchesMonitor;
251 begin
252 Result := Debugger.Watches;
253 end;
254
InternalFeedBacknull255 function TGDBTestCase.InternalFeedBack(Sender: TObject; const AText, AInfo: String;
256 AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
257 begin
258 Result := frOk;
259 DebugLn(['**** Feedback requested ****: ', AText]);
260 DebugLn(['**** ', AInfo]);
261 end;
262
263 procedure TGDBTestCase.InternalDbgEvent(Sender: TObject;
264 const ACategory: TDBGEventCategory; const AEventType: TDBGEventType;
265 const AText: String);
266 begin
267 case ACategory of
268 ecBreakpoint: ;
269 ecProcess: ;
270 ecThread: ;
271 ecModule: ;
272 ecOutput: ;
273 ecWindows: ;
274 ecDebugger: begin
275 case AEventType of
276 etDefault: begin
277 // maybe crash / internal error? Text from IDE not GDB (po file)
278 if (Pos('internal error:', LowerCase(AText)) > 0) then
279 inc(FTotalGDBInternalErrorCnt);
280 end;
281 end;
282 end;
283 end;
284 end;
285
TGDBTestCase.GetCompilerInfonull286 function TGDBTestCase.GetCompilerInfo: TCompilerInfo;
287 begin
288 Result := TCompilerSuite(Parent).CompilerInfo;
289 end;
290
GetDebuggerInfonull291 function TGDBTestCase.GetDebuggerInfo: TDebuggerInfo;
292 begin
293 Result := TCompilerSuite(Parent).DebuggerInfo;
294 end;
295
GetSymbolTypenull296 function TGDBTestCase.GetSymbolType: TSymbolType;
297 begin
298 Result := TCompilerSuite(Parent).SymbolType;
299 end;
300
301 procedure TGDBTestCase.SetUp;
302 begin
303 FLogDebuglnCount := 0;
304 FTotalGDBInternalErrorCnt := 0;
305 FTotalDsErrorCrash := 0;
306 FTotalClassVsRecord := 0;
307 FStartTime := GetTickCount64;
308 inherited SetUp;
309 end;
310
TGDBTestCase.GetFinalLogFileNamenull311 function TGDBTestCase.GetFinalLogFileName: String;
312 var
313 i: QWord;
314 begin
315 Result := inherited GetFinalLogFileName;
316
317 i := GetTickCount64;
318 if i >= FStartTime then
319 i := i - FStartTime
320 else
321 i := high(QWord) - FStartTime + 1 + i;
322
323 if FTotalGDBInternalErrorCnt > 0
324 then Result := Result + '___gdb_intern.'+IntToStr(FTotalGDBInternalErrorCnt);
325 if FTotalDsErrorCrash > 0
326 then Result := Result + '___gdb_crash.'+IntToStr(FTotalDsErrorCrash);
327 if FTotalClassVsRecord > 0
328 then Result := Result + '___class_re._'+IntToStr(FTotalClassVsRecord);
329
330 // Result := Result + '___time.'+ IntToStr(i div 1000);
331 end;
332
TGDBTestCase.StartGDBnull333 function TGDBTestCase.StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;
334 begin
335 Result := GdbClass.Create(DebuggerInfo.ExeName);
336 try
337 Debugger.LazDebugger := Result;
338 Result.OnDbgOutput := @InternalDbgOutPut;
339 Result.OnFeedback := @InternalFeedBack;
340 Result.OnDbgEvent:=@InternalDbgEvent;
341
342 Debugger.InitDebuggerMonitors(Result);
343
344 Result.Init;
345 if Result.State = dsError then
346 Fail(' Failed Init');
347 Result.WorkingDir := AppDir;
348 Result.FileName := TestExeName;
349 Result.Arguments := '';
350 Result.ShowConsole := True;
351 except
352 on e: Exception do
353 Fail('INIT Exception: '+E.Message);
354 end;
355 end;
356
357 procedure TGDBTestCase.CleanGdb;
358 begin
359 Debugger.ClearDebuggerMonitors;
360 end;
361
362 procedure TGDBTestCase.LogToFile(const s: string);
363 begin
364 LogText('## '+s);
365 end;
366
367 { TCompilerList }
368
TCompilerList.GetCompilerInfonull369 function TCompilerList.GetCompilerInfo(Index: Integer): TCompilerInfo;
370 begin
371 Result := FullInfo[Index];
372 end;
373
374 { TDebuggerList }
375
GetDebuggerInfonull376 function TDebuggerList.GetDebuggerInfo(Index: Integer): TDebuggerInfo;
377 begin
378 Result := FullInfo[Index];
379 end;
380
381 { TCompilerSuite }
382
TCompilerSuite.GetCompilerInfonull383 function TCompilerSuite.GetCompilerInfo: TExternalExeInfo;
384 begin
385 Result := Compiler.FullInfo;
386 end;
387
TCompilerSuite.GetDebuggerInfonull388 function TCompilerSuite.GetDebuggerInfo: TExternalExeInfo;
389 begin
390 Result := Debugger.FullInfo;
391 end;
392
GetSymbolTypenull393 function TCompilerSuite.GetSymbolType: TSymbolType;
394 begin
395 Result := Compiler.SymbolType;
396 end;
397
398 constructor TCompilerSuite.Create;
399 begin
400 inherited Create;
401 FSymbolSwitch := SymbolTypeSwitches[SymbolType];
402 FFileNameExt := SymbolTypeNames[SymbolType] + '_' + NameToFileName(CompilerInfo.Name);
403 end;
404
405
406 { --- }
407
408 procedure BuildTestSuites;
409 var
410 FpcList: TCompilerList;
411 GdbList: TDebuggerList;
412 begin
413 FpcList := GetCompilers;
414 GdbList := GetDebuggers;
415
416 CreateCompilerList(FpcList, TTestDbgCompiler);
417 CreateDebuggerList(GdbList, TTestDbgDebugger);
418 CreateTestSuites(TestDbgCompilerList, TestDbgDebuggerList, TCompilerSuite);
419
420 TestControlRegisterCompilers(FpcList);
421 TestControlRegisterDebuggers(GdbList);
422 end;
423
CheckAppDirnull424 function CheckAppDir(var AppDir: string): Boolean;
425 begin
426 Result := DirectoryExistsUTF8(AppDir + 'TestApps');
427 end;
428
CheckAppDirLibnull429 function CheckAppDirLib(var AppDir: string): Boolean;
430 var
431 s: string;
432 begin
433 Result := False;
434 if RightStr(AppDir, length('lib' + DirectorySeparator)) = 'lib' + DirectorySeparator
435 then begin
436 s := copy(AppDir, 1, length(AppDir) - length('lib' + DirectorySeparator));
437 Result := DirectoryExistsUTF8(s + 'TestApps');
438 if Result then
439 AppDir := s;
440 end;
441 end;
442
AppDirStripAppBundlenull443 function AppDirStripAppBundle(AppDir: string): String;
444 var
445 p: LongInt;
446 begin
447 Result := AppDir;
448 p := pos('.app' + DirectorySeparator, AppDir);
449 while (p > 1) and (AppDir[p-1] <> DirectorySeparator) do
450 dec(p);
451 if p > 1 then
452 Result := Copy(AppDir, 1, p - 1);
453 end;
454
455 initialization
456 // GDBMIDebugger is un uses
457 DebugLogger.FindOrRegisterLogGroup('DBG_CMD_ECHO' , True )^.Enabled := True;
458 DebugLogger.FindOrRegisterLogGroup('DBGMI_QUEUE_DEBUG' , True )^.Enabled := True;
459 DebugLogger.FindOrRegisterLogGroup('DBGMI_STRUCT_PARSER' , True )^.Enabled := True;
460 DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' , True )^.Enabled := True;
461 DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS', True )^.Enabled := True;
462 DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER', True )^.Enabled := True;
463 DebugLogger.FindOrRegisterLogGroup('DBGMI_TYPE_INFO', True )^.Enabled := True;
464 DebugLogger.FindOrRegisterLogGroup('DBGMI_TIMEOUT_DEBUG', True )^.Enabled := True;
465 DebugLogger.FindOrRegisterLogGroup('DBG_THREAD_AND_FRAME', True )^.Enabled := True;
466
467 DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_ERRORS', True);
468 DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_SEARCH', True)^.Enabled := True;
469 DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_WARNINGS', True)^.Enabled := True;
470 DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_VERBOSE', True);
471 DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_DATA_WARNINGS', True);
472
473
474 AppDir := AppendPathDelim(ExtractFilePath(Paramstr(0)));
475 if not(CheckAppDir(AppDir))
476 and not(CheckAppDirLib(AppDir))
477 then begin
478 AppDir := AppDirStripAppBundle(AppDir);
479 if not(CheckAppDir(AppDir))
480 and not(CheckAppDirLib(AppDir))
481 then
482 with TSelectDirectoryDialog.Create(nil) do begin
483 if Execute then AppDir := AppendPathDelim(FileName);
484 Free;
485 end;
486 end;
487 ConfDir := AppDir;
488 AppDir := AppendPathDelim(AppDir + 'TestApps');
489
490 if DirectoryExistsUTF8(ConfDir+'logs') then
491 TestControlSetLogPath(ConfDir+'logs'+DirectorySeparator)
492 else if DirectoryExistsUTF8(ConfDir+'log') then
493 TestControlSetLogPath(ConfDir+'log'+DirectorySeparator)
494 else
495 TestControlSetLogPath(ConfDir);
496
497
498 //EnvironmentOptions := TEnvironmentOptions.Create;
499 //with EnvironmentOptions do
500 //begin
501 // CreateConfig;
502 // Load(false);
503 //end;
504 //GlobalMacroList:=TTransferMacroList.Create;
505
506 BuildTestSuites;
507
508 finalization
509 FreeAndNil(Compilers);
510 FreeAndNil(Debuggers);
511 //FreeAndNil(EnvironmentOptions);
512
513 end.
514
515