1 unit RunGdbmiForm;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, FileUtil, LazFileUtils, LazLogger, Forms, Controls,
9 Graphics, Dialogs, ExtCtrls, EditBtn, StdCtrls, Buttons, TestBase,
10 testregistry, fpcunit, GDBMIDebugger, LCLIntf, DbgIntfDebuggerBase, CheckLst,
11 Spin, CmdLineDebugger, TTestDbgExecuteables, TestDbgConfig, TestDbgTestSuites,
12 TestDbgControl, TestCommonSources, strutils, math, fgl;
13
14 type
15
16 { TForm1 }
17
18 TForm1 = class(TForm)
19 BitBtn1: TBitBtn;
20 BtnRun: TButton;
21 chkCSF: TCheckBox;
22 chkDeDup: TCheckBox;
23 chkDebugln: TCheckBox;
24 chkStripEcho: TCheckBox;
25 chkWatch: TCheckBox;
26 EdDefine: TEdit;
27 edUses: TEdit;
28 edPasFile: TEdit;
29 edPasHistory: TComboBox;
30 edBreakFile: TEdit;
31 edBreakLine: TEdit;
32 Label1: TLabel;
33 Label2: TLabel;
34 Label3: TLabel;
35 Label4: TLabel;
36 Label5: TLabel;
37 Label6: TLabel;
38 Memo1: TMemo;
39 Memo2: TMemo;
40 OpenDialog1: TOpenDialog;
41 Panel1: TPanel;
42 Panel2: TPanel;
43 SpinHC: TSpinEdit;
44 Splitter1: TSplitter;
45 Splitter3: TSplitter;
46 procedure BitBtn1Click(Sender: TObject);
47 procedure BtnRunClick(Sender: TObject);
48 procedure edPasFileChange(Sender: TObject);
49 procedure edPasHistoryChange(Sender: TObject);
50 procedure FormCreate(Sender: TObject);
51 private
52 { private declarations }
53 FMemoAppendText: String;
54 FDeferAppend: Boolean;
55 public
56 { public declarations }
57 EchoText: string;
58 procedure AppendToMemo2(Txt: String);
59 end;
60
61 var
62 Form1: TForm1;
63
64 implementation
65 type TStringMap = specialize TFPGMap<String, String>;
66 var
67 ControlTestRunner: Pointer;
68 FResultList: TStringMap;
69
70 {$R *.lfm}
71
72 type
73
74 { TRunner }
75
76 TRunner = class(TGDBTestCase)
77 private
78 FTesting: Boolean;
79 FRecordDebugln: Boolean;
80 procedure dobrk(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint;
81 var ACanContinue: Boolean);
82 protected
83 procedure DoAddOutput(const AText: String);
84 procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); override;
85 procedure DoDebugln(Sender: TObject; S: string; var Handled: Boolean); override;
86 procedure DoDbgOutput(Sender: TObject; const AText: String);
87 published
88 procedure DoRun;
89 end;
90
EscQnull91 function EscQ(s: string): String;
92 begin
93 Result := StringReplace(s, '"', '""', [rfReplaceAll]);
94 end;
95
96 { TRunner }
97
98 procedure TRunner.dobrk(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint;
99 var ACanContinue: Boolean);
100 begin
101 ACanContinue := False;
102 end;
103
104 procedure TRunner.DoAddOutput(const AText: String);
105 var s: string;
106 i: Integer;
107 begin
108 if not FTesting then exit;
109
110 if Form1.chkStripEcho.Checked then begin
111 s := trim(AText);
112 if (copy(AText, 1, 1) = '&') then exit;
113 if (Form1.EchoText <> '') and ('<'+Form1.EchoText+'>' = s) then exit;
114 if (s = '(gdb)') or (s = '^done') then exit;
115 end;
116 Form1.EchoText := '';
117
118 if Form1.chkCSF.Checked
119 then begin
120 s := AText;
121 if (copy(s, 1, 2) = '~"') and (copy(s, length(AText), 1) = '"') then begin
122 Delete(s,1,2);
123 Delete(s,length(s),1);
124 end;
125 //S := AnsiReplaceStr(AText, #13, '\r');
126 //S := AnsiReplaceStr(AText, #10, '\n');
127 Form1.AppendToMemo2(EscQ(s) + LineEnding);
128 end
129 else
130 Form1.Memo2.Lines.Add(AText);
131 end;
132
133 procedure TRunner.DoDbgOut(Sender: TObject; S: string; var Handled: Boolean);
134 begin
135 inherited DoDbgOut(Sender, S, Handled);
136 if not FRecordDebugln then exit;
137
138 DoAddOutput(s);
139 end;
140
141 procedure TRunner.DoDebugln(Sender: TObject; S: string; var Handled: Boolean);
142 begin
143 inherited DoDebugln(Sender, S, Handled);
144 if not FRecordDebugln then exit;
145
146 DoAddOutput(s);
147 end;
148
149 procedure TRunner.DoDbgOutput(Sender: TObject; const AText: String);
150 begin
151 if FRecordDebugln then exit;
152
153 DoAddOutput(AText);
154 end;
155
156 type THack = class(TCmdLineDebugger) end;
157
158 procedure TRunner.DoRun;
159 var
160 RunAsWatch: Boolean;
161
RemoveHexNumbersnull162 function RemoveHexNumbers(txt: String): String;
163 var
164 i, j: Integer;
165 p, p2: SizeInt;
166 s: String;
167 begin
168 Result := txt;
169 i := 1;
170 j := 1;
171 p := PosEx('0x', Result, i);
172 while p > 0 do begin
173 i := p+2;
174
175 p2 := p + 2;
176 while (p2 <= Length(Result)) and (Result[p2] in ['0'..'9', 'a'..'f', 'A'..'F']) do
177 inc(p2);
178 if p2 - p > 6 then begin
179 s := copy(Result, p, p2-p);
180 Result := StringReplace(Result, s, '##$$##HEX'+IntToStr(j)+'##', [rfReplaceAll, rfIgnoreCase]);
181 end;
182
183 inc(j);
184 p := PosEx('0x', Result, i);
185 end;
186 end;
187
188 procedure DoOneRun(Name: String; UsesDirs: array of TUsesDir);
189 var
190 TestExeName, s, s2, R: string;
191 dbg: TGDBMIDebugger;
192 i, j , hc: Integer;
193 Src: TCommonSource;
194 RT: TDBGType;
195 begin
196 ClearTestErrors;
197 FTesting := False;
198
199 if Form1.chkCSF.Checked
200 then begin
201 Form1.AppendToMemo2('"' + EscQ(Parent.TestName) + ' ' + Name + '",');
202 end
203 else
204 Form1.Memo2.Lines.Add('***** '+ Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + Name);
205
206 try
207 Src := GetCommonSourceFor(Form1.edPasFile.Text);
208
209 TestCompile(Src, TestExeName, UsesDirs, '', Form1.EdDefine.Text);
210 except
211 on e: Exception do
212 Form1.Memo2.Lines.Add('Compile error: ' + e.Message);
213 end;
214
215
216 Form1.FMemoAppendText := '';
217 Form1.FDeferAppend := Form1.chkDeDup.Checked and (FResultList<> nil);
218 try
219 dbg := StartGDB(AppDir, TestExeName);
220 try
221 dbg.OnDbgOutput := @DoDbgOutput;
222 dbg.OnBreakPointHit := @dobrk;
223
224 (* Add breakpoints *)
225 i := StrToIntDef(Form1.edBreakLine.Text, 0);
226 if i > 0 then
227 Debugger.SetBreakPoint(Src.FileName, i)
228 else
229 Debugger.SetBreakPoint(Src, Form1.edBreakLine.Text);
230
231 (* Start debugging *)
232 //if dbg.State = dsError then begin
233 // Form1.Memo2.Lines.Add('Failed to start');
234 // exit;
235 //end;
236
237 hc := Form1.SpinHC.Value;
238 if hc < 1 then hc := 1;
239
240 while hc > 0 do begin
241 dbg.Run;
242 dec(hc);
243 end;
244
245 //t:= GetTickCount;
246 if Form1.chkCSF.Checked then begin
247 Form1.AppendToMemo2('"');
248 end;
249
250 for i := 0 to Form1.Memo1.Lines.Count - 1 do begin
251 if Trim(Form1.Memo1.Lines[i])<> '' then begin
252 if FRecordDebugln then begin
253 while DebugLogger.CurrentIndentLevel > 0 do
254 DebugLogger.DebugLnExit;
255 end;
256
257 FTesting := True;
258 try
259 Form1.EchoText := Trim(Form1.Memo1.Lines[i]);
260 if RunAsWatch then begin
261 dbg.EvaluateWait(Form1.EchoText, R, RT, [], 3000);
262 DoAddOutput(R);
263 end
264 else
265 dbg.TestCmd(Form1.EchoText);
266 finally
267 FTesting := False;
268 end;
269 end;
270 if Form1.chkCSF.Checked then
271 Form1.AppendToMemo2('","');
272 end;
273 if Form1.chkCSF.Checked then begin
274 Form1.AppendToMemo2('"');
275 end;
276
277
278 dbg.Stop;
279 finally
280 dbg.Free;
281 CleanGdb;
282 end;
283 finally
284 if Form1.FDeferAppend then begin
285 Form1.FDeferAppend := False;
286
287 s := Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + Name;
288 s2 := RemoveHexNumbers(Form1.FMemoAppendText);
289 if FResultList.Find(s2, i) then begin
290 s := FResultList.Data[i];
291 Form1.AppendToMemo2('"'+EscQ('EQUAL TO: '+s)+'"');
292 end
293 else begin
294 FResultList.Add(s2, s);
295 Form1.AppendToMemo2(Form1.FMemoAppendText);
296 end;
297 end;
298 Form1.Memo2.Lines.Add(' ');
299
300 Form1.FMemoAppendText := '';
301 end;
302 end;
303
304 var
305 AUsesDir: TUsesDir;
306 ii: TSymbolType;
307 begin
308 Form1.Caption := 'Running: '+ Parent.TestSuiteName + ' ' + Parent.TestName;
309
310 if SkipTest then exit;
311 if not TestControlCanTest(ControlTestRunner) then exit;
312
313 RunAsWatch := Form1.chkWatch.Checked;
314 FRecordDebugln := Form1.chkDebugln.Checked;
315
316 if Form1.edUses.Text <> '' then begin
317
318 //with AUsesDir do begin
319 // DirName := Form1.edUses.Text;
320 // ExeId:= '';
321 // SymbolType:= stNone;
322 // ExtraOpts:= '';
323 // NamePostFix:= ''
324 //end;
325 //DoOneRun('none', [AUsesDir]);
326
327 for ii := low(TSymbolType) to high(TSymbolType) do begin
328 if not TestControlCanSymType(ii) then continue;
329
330 if (ii in CompilerInfo.SymbolTypes) and (ii in DebuggerInfo.SymbolTypes)
331 then begin
332 with AUsesDir do begin
333 DirName := Form1.edUses.Text;
334 ExeId:= '';
335 SymbolType:= ii;
336 ExtraOpts:= '';
337 NamePostFix:= ''
338 end;
339 DoOneRun(SymbolTypeNames[ii], [AUsesDir]);
340 end;
341 end;
342 //
343 // if (stDwarf in CompilerInfo.SymbolTypes) and (stDwarf in DebuggerInfo.SymbolTypes)
344 // then begin
345 // with AUsesDir do begin
346 // DirName := Form1.edUses.Text;
347 // ExeId:= '';
348 // SymbolType:= stDwarf;
349 // ExtraOpts:= '';
350 // NamePostFix:= ''
351 // end;
352 // DoOneRun('stDwarf', [AUsesDir]);
353 // end;
354 //
355 // if (stDwarfSet in CompilerInfo.SymbolTypes) and (stDwarfSet in DebuggerInfo.SymbolTypes)
356 // then begin
357 // with AUsesDir do begin
358 // DirName := Form1.edUses.Text;
359 // ExeId:= '';
360 // SymbolType:= stDwarfSet;
361 // ExtraOpts:= '';
362 // NamePostFix:= ''
363 // end;
364 // DoOneRun('stabsSet', [AUsesDir]);
365 // end;
366 //
367 // if (stDwarf3 in CompilerInfo.SymbolTypes) and (stDwarf3 in DebuggerInfo.SymbolTypes)
368 // then begin
369 // with AUsesDir do begin
370 // DirName := Form1.edUses.Text;
371 // ExeId:= '';
372 // SymbolType:= stDwarf3;
373 // ExtraOpts:= '';
374 // NamePostFix:= ''
375 // end;
376 // DoOneRun('stDwarf3', [AUsesDir]);
377 // end;
378
379
380 end
381 else
382 DoOneRun('', []);
383 end;
384
385 { TForm1 }
386
387 procedure TForm1.BtnRunClick(Sender: TObject);
388 var
389 Dummy: TTestResult;
390 i: Integer;
391 begin
392 edPasHistory.AddHistoryItem
393 (edPasFile.Text + '*' + edBreakFile.Text + '*' + edBreakLine.Text + '*' + edUses.Text + '*' + EdDefine.Text,
394 15, True, False);
395 edPasHistory.Items.SaveToFile(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt');
396
397 FResultList:= TStringMap.Create;
398 FResultList.Sorted := True;
399
400 if Memo2.Lines.Count > 0 then begin;
401 Memo2.Lines.Add('');
402 Memo2.Lines.Add('----- ***** ----- ***** ----- ***** -----');
403 Memo2.Lines.Add('');
404 end;
405
406 if Form1.chkCSF.Checked then begin
407 Form1.AppendToMemo2(LineEnding + '"-","');
408 for i := 0 to Form1.Memo1.Lines.Count - 1 do begin
409 Form1.AppendToMemo2(EscQ(Trim(Form1.Memo1.Lines[i])) + '","');
410 end;
411 Form1.AppendToMemo2('"' + LineEnding);
412 end;
413
414 Dummy := TTestResult.Create;
415 GetTestRegistry.Run(Dummy);
416 Dummy.Free;
417
418 //for i := 0 to FTests.Count - 1 do
419 //RunTest(TTest(FTests[i]), AResult);
420
421 Form1.Caption := 'Done';
422 FreeAndNil(FResultList);
423 end;
424
425 procedure TForm1.edPasFileChange(Sender: TObject);
426 begin
427
428 end;
429
430 procedure TForm1.edPasHistoryChange(Sender: TObject);
431 var
432 t: TCaption;
433 i: SizeInt;
434 begin
435 t := edPasHistory.Text;
436 i := pos('*', t)-1;
437 if i < 0 then i := length(t);
438 edPasFile.Text := copy(t, 1, i);
439 delete(t,1,i+1);
440
441 i := pos('*', t)-1;
442 if i < 0 then i := length(t);
443 edBreakFile.Text := copy(t, 1, i);
444 delete(t,1,i+1);
445
446 i := pos('*', t)-1;
447 if i < 0 then i := length(t);
448 edBreakLine.Text := copy(t, 1, i);
449 delete(t,1,i+1);
450
451 i := pos('*', t)-1;
452 if i < 0 then i := length(t);
453 edUses.Text := copy(t, 1, i);
454 delete(t,1,i+1);
455
456 EdDefine.Text := copy(t, 1, i);
457 end;
458
459 procedure TForm1.FormCreate(Sender: TObject);
460 begin
461 if FileExistsUTF8(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt') then
462 edPasHistory.Items.LoadFromFile(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt');
463 if edPasHistory.Items.Count > 0 then
464 edPasHistory.ItemIndex := 0;
465 edBreakFile.Text := ExtractFileName(edPasHistory.Text);
466 edBreakLine.Text := '1';
467
468 edPasHistoryChange(nil);
469 end;
470
471 procedure TForm1.AppendToMemo2(Txt: String);
472 var
473 i: Integer;
474 begin
475 if FDeferAppend then begin
476 FMemoAppendText := FMemoAppendText + Txt;
477 exit;
478 end;
479
480 i := Memo2.Lines.Count;
481 if (i = 0)then
482 Memo2.Append(Txt)
483 else
484 Memo2.Lines[i-1] := Memo2.Lines[i-1] + Txt;
485 end;
486
487 procedure TForm1.BitBtn1Click(Sender: TObject);
488 begin
489 if not OpenDialog1.Execute then exit;
490 edPasFile.Text := OpenDialog1.FileName;
491 edBreakFile.Text := ExtractFileName(edPasHistory.Text);
492 edBreakLine.Text := '1';
493 end;
494
495 initialization
496
497 RegisterDbgTest(TRunner);
498 ControlTestRunner := TestControlRegisterTest('Run');
499
500 end.
501
502
503