mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-05 21:52:44 +02:00
503 lines
12 KiB
ObjectPascal
503 lines
12 KiB
ObjectPascal
unit RunGdbmiForm;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, FileUtil, LazFileUtils, LazLogger, Forms, Controls,
|
|
Graphics, Dialogs, ExtCtrls, EditBtn, StdCtrls, Buttons, TestBase,
|
|
testregistry, fpcunit, GDBMIDebugger, LCLIntf, DbgIntfDebuggerBase, CheckLst,
|
|
Spin, CmdLineDebugger, TTestDbgExecuteables, TestDbgConfig, TestDbgTestSuites,
|
|
TestDbgControl, TestCommonSources, strutils, math, fgl;
|
|
|
|
type
|
|
|
|
{ TForm1 }
|
|
|
|
TForm1 = class(TForm)
|
|
BitBtn1: TBitBtn;
|
|
BtnRun: TButton;
|
|
chkCSF: TCheckBox;
|
|
chkDeDup: TCheckBox;
|
|
chkDebugln: TCheckBox;
|
|
chkStripEcho: TCheckBox;
|
|
chkWatch: TCheckBox;
|
|
EdDefine: TEdit;
|
|
edUses: TEdit;
|
|
edPasFile: TEdit;
|
|
edPasHistory: TComboBox;
|
|
edBreakFile: TEdit;
|
|
edBreakLine: TEdit;
|
|
Label1: TLabel;
|
|
Label2: TLabel;
|
|
Label3: TLabel;
|
|
Label4: TLabel;
|
|
Label5: TLabel;
|
|
Label6: TLabel;
|
|
Memo1: TMemo;
|
|
Memo2: TMemo;
|
|
OpenDialog1: TOpenDialog;
|
|
Panel1: TPanel;
|
|
Panel2: TPanel;
|
|
SpinHC: TSpinEdit;
|
|
Splitter1: TSplitter;
|
|
Splitter3: TSplitter;
|
|
procedure BitBtn1Click(Sender: TObject);
|
|
procedure BtnRunClick(Sender: TObject);
|
|
procedure edPasFileChange(Sender: TObject);
|
|
procedure edPasHistoryChange(Sender: TObject);
|
|
procedure FormCreate(Sender: TObject);
|
|
private
|
|
{ private declarations }
|
|
FMemoAppendText: String;
|
|
FDeferAppend: Boolean;
|
|
public
|
|
{ public declarations }
|
|
EchoText: string;
|
|
procedure AppendToMemo2(Txt: String);
|
|
end;
|
|
|
|
var
|
|
Form1: TForm1;
|
|
|
|
implementation
|
|
type TStringMap = specialize TFPGMap<String, String>;
|
|
var
|
|
ControlTestRunner: Pointer;
|
|
FResultList: TStringMap;
|
|
|
|
{$R *.lfm}
|
|
|
|
type
|
|
|
|
{ TRunner }
|
|
|
|
TRunner = class(TGDBTestCase)
|
|
private
|
|
FTesting: Boolean;
|
|
FRecordDebugln: Boolean;
|
|
procedure dobrk(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint;
|
|
var ACanContinue: Boolean);
|
|
protected
|
|
procedure DoAddOutput(const AText: String);
|
|
procedure DoDbgOut(Sender: TObject; S: string; var Handled: Boolean); override;
|
|
procedure DoDebugln(Sender: TObject; S: string; var Handled: Boolean); override;
|
|
procedure DoDbgOutput(Sender: TObject; const AText: String);
|
|
published
|
|
procedure DoRun;
|
|
end;
|
|
|
|
function EscQ(s: string): String;
|
|
begin
|
|
Result := StringReplace(s, '"', '""', [rfReplaceAll]);
|
|
end;
|
|
|
|
{ TRunner }
|
|
|
|
procedure TRunner.dobrk(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint;
|
|
var ACanContinue: Boolean);
|
|
begin
|
|
ACanContinue := False;
|
|
end;
|
|
|
|
procedure TRunner.DoAddOutput(const AText: String);
|
|
var s: string;
|
|
i: Integer;
|
|
begin
|
|
if not FTesting then exit;
|
|
|
|
if Form1.chkStripEcho.Checked then begin
|
|
s := trim(AText);
|
|
if (copy(AText, 1, 1) = '&') then exit;
|
|
if (Form1.EchoText <> '') and ('<'+Form1.EchoText+'>' = s) then exit;
|
|
if (s = '(gdb)') or (s = '^done') then exit;
|
|
end;
|
|
Form1.EchoText := '';
|
|
|
|
if Form1.chkCSF.Checked
|
|
then begin
|
|
s := AText;
|
|
if (copy(s, 1, 2) = '~"') and (copy(s, length(AText), 1) = '"') then begin
|
|
Delete(s,1,2);
|
|
Delete(s,length(s),1);
|
|
end;
|
|
//S := AnsiReplaceStr(AText, #13, '\r');
|
|
//S := AnsiReplaceStr(AText, #10, '\n');
|
|
Form1.AppendToMemo2(EscQ(s) + LineEnding);
|
|
end
|
|
else
|
|
Form1.Memo2.Lines.Add(AText);
|
|
end;
|
|
|
|
procedure TRunner.DoDbgOut(Sender: TObject; S: string; var Handled: Boolean);
|
|
begin
|
|
inherited DoDbgOut(Sender, S, Handled);
|
|
if not FRecordDebugln then exit;
|
|
|
|
DoAddOutput(s);
|
|
end;
|
|
|
|
procedure TRunner.DoDebugln(Sender: TObject; S: string; var Handled: Boolean);
|
|
begin
|
|
inherited DoDebugln(Sender, S, Handled);
|
|
if not FRecordDebugln then exit;
|
|
|
|
DoAddOutput(s);
|
|
end;
|
|
|
|
procedure TRunner.DoDbgOutput(Sender: TObject; const AText: String);
|
|
begin
|
|
if FRecordDebugln then exit;
|
|
|
|
DoAddOutput(AText);
|
|
end;
|
|
|
|
type THack = class(TCmdLineDebugger) end;
|
|
|
|
procedure TRunner.DoRun;
|
|
var
|
|
RunAsWatch: Boolean;
|
|
|
|
function RemoveHexNumbers(txt: String): String;
|
|
var
|
|
i, j: Integer;
|
|
p, p2: SizeInt;
|
|
s: String;
|
|
begin
|
|
Result := txt;
|
|
i := 1;
|
|
j := 1;
|
|
p := PosEx('0x', Result, i);
|
|
while p > 0 do begin
|
|
i := p+2;
|
|
|
|
p2 := p + 2;
|
|
while (p2 <= Length(Result)) and (Result[p2] in ['0'..'9', 'a'..'f', 'A'..'F']) do
|
|
inc(p2);
|
|
if p2 - p > 6 then begin
|
|
s := copy(Result, p, p2-p);
|
|
Result := StringReplace(Result, s, '##$$##HEX'+IntToStr(j)+'##', [rfReplaceAll, rfIgnoreCase]);
|
|
end;
|
|
|
|
inc(j);
|
|
p := PosEx('0x', Result, i);
|
|
end;
|
|
end;
|
|
|
|
procedure DoOneRun(Name: String; UsesDirs: array of TUsesDir);
|
|
var
|
|
TestExeName, s, s2, R: string;
|
|
dbg: TGDBMIDebugger;
|
|
i, j , hc: Integer;
|
|
Src: TCommonSource;
|
|
RT: TDBGType;
|
|
begin
|
|
ClearTestErrors;
|
|
FTesting := False;
|
|
|
|
if Form1.chkCSF.Checked
|
|
then begin
|
|
Form1.AppendToMemo2('"' + EscQ(Parent.TestName) + ' ' + Name + '",');
|
|
end
|
|
else
|
|
Form1.Memo2.Lines.Add('***** '+ Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + Name);
|
|
|
|
try
|
|
Src := GetCommonSourceFor(Form1.edPasFile.Text);
|
|
|
|
TestCompile(Src, TestExeName, UsesDirs, '', Form1.EdDefine.Text);
|
|
except
|
|
on e: Exception do
|
|
Form1.Memo2.Lines.Add('Compile error: ' + e.Message);
|
|
end;
|
|
|
|
|
|
Form1.FMemoAppendText := '';
|
|
Form1.FDeferAppend := Form1.chkDeDup.Checked and (FResultList<> nil);
|
|
try
|
|
dbg := StartGDB(AppDir, TestExeName);
|
|
try
|
|
dbg.OnDbgOutput := @DoDbgOutput;
|
|
dbg.OnBreakPointHit := @dobrk;
|
|
|
|
(* Add breakpoints *)
|
|
i := StrToIntDef(Form1.edBreakLine.Text, 0);
|
|
if i > 0 then
|
|
Debugger.SetBreakPoint(Src.FileName, i)
|
|
else
|
|
Debugger.SetBreakPoint(Src, Form1.edBreakLine.Text);
|
|
|
|
(* Start debugging *)
|
|
//if dbg.State = dsError then begin
|
|
// Form1.Memo2.Lines.Add('Failed to start');
|
|
// exit;
|
|
//end;
|
|
|
|
hc := Form1.SpinHC.Value;
|
|
if hc < 1 then hc := 1;
|
|
|
|
while hc > 0 do begin
|
|
dbg.Run;
|
|
dec(hc);
|
|
end;
|
|
|
|
//t:= GetTickCount;
|
|
if Form1.chkCSF.Checked then begin
|
|
Form1.AppendToMemo2('"');
|
|
end;
|
|
|
|
for i := 0 to Form1.Memo1.Lines.Count - 1 do begin
|
|
if Trim(Form1.Memo1.Lines[i])<> '' then begin
|
|
if FRecordDebugln then begin
|
|
while DebugLogger.CurrentIndentLevel > 0 do
|
|
DebugLogger.DebugLnExit;
|
|
end;
|
|
|
|
FTesting := True;
|
|
try
|
|
Form1.EchoText := Trim(Form1.Memo1.Lines[i]);
|
|
if RunAsWatch then begin
|
|
dbg.EvaluateWait(Form1.EchoText, R, RT, [], 3000);
|
|
DoAddOutput(R);
|
|
end
|
|
else
|
|
dbg.TestCmd(Form1.EchoText);
|
|
finally
|
|
FTesting := False;
|
|
end;
|
|
end;
|
|
if Form1.chkCSF.Checked then
|
|
Form1.AppendToMemo2('","');
|
|
end;
|
|
if Form1.chkCSF.Checked then begin
|
|
Form1.AppendToMemo2('"');
|
|
end;
|
|
|
|
|
|
dbg.Stop;
|
|
finally
|
|
dbg.Free;
|
|
CleanGdb;
|
|
end;
|
|
finally
|
|
if Form1.FDeferAppend then begin
|
|
Form1.FDeferAppend := False;
|
|
|
|
s := Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + Name;
|
|
s2 := RemoveHexNumbers(Form1.FMemoAppendText);
|
|
if FResultList.Find(s2, i) then begin
|
|
s := FResultList.Data[i];
|
|
Form1.AppendToMemo2('"'+EscQ('EQUAL TO: '+s)+'"');
|
|
end
|
|
else begin
|
|
FResultList.Add(s2, s);
|
|
Form1.AppendToMemo2(Form1.FMemoAppendText);
|
|
end;
|
|
end;
|
|
Form1.Memo2.Lines.Add(' ');
|
|
|
|
Form1.FMemoAppendText := '';
|
|
end;
|
|
end;
|
|
|
|
var
|
|
AUsesDir: TUsesDir;
|
|
ii: TSymbolType;
|
|
begin
|
|
Form1.Caption := 'Running: '+ Parent.TestSuiteName + ' ' + Parent.TestName;
|
|
|
|
if SkipTest then exit;
|
|
if not TestControlCanTest(ControlTestRunner) then exit;
|
|
|
|
RunAsWatch := Form1.chkWatch.Checked;
|
|
FRecordDebugln := Form1.chkDebugln.Checked;
|
|
|
|
if Form1.edUses.Text <> '' then begin
|
|
|
|
//with AUsesDir do begin
|
|
// DirName := Form1.edUses.Text;
|
|
// ExeId:= '';
|
|
// SymbolType:= stNone;
|
|
// ExtraOpts:= '';
|
|
// NamePostFix:= ''
|
|
//end;
|
|
//DoOneRun('none', [AUsesDir]);
|
|
|
|
for ii := low(TSymbolType) to high(TSymbolType) do begin
|
|
if not TestControlCanSymType(ii) then continue;
|
|
|
|
if (ii in CompilerInfo.SymbolTypes) and (ii in DebuggerInfo.SymbolTypes)
|
|
then begin
|
|
with AUsesDir do begin
|
|
DirName := Form1.edUses.Text;
|
|
ExeId:= '';
|
|
SymbolType:= ii;
|
|
ExtraOpts:= '';
|
|
NamePostFix:= ''
|
|
end;
|
|
DoOneRun(SymbolTypeNames[ii], [AUsesDir]);
|
|
end;
|
|
end;
|
|
//
|
|
// if (stDwarf in CompilerInfo.SymbolTypes) and (stDwarf in DebuggerInfo.SymbolTypes)
|
|
// then begin
|
|
// with AUsesDir do begin
|
|
// DirName := Form1.edUses.Text;
|
|
// ExeId:= '';
|
|
// SymbolType:= stDwarf;
|
|
// ExtraOpts:= '';
|
|
// NamePostFix:= ''
|
|
// end;
|
|
// DoOneRun('stDwarf', [AUsesDir]);
|
|
// end;
|
|
//
|
|
// if (stDwarfSet in CompilerInfo.SymbolTypes) and (stDwarfSet in DebuggerInfo.SymbolTypes)
|
|
// then begin
|
|
// with AUsesDir do begin
|
|
// DirName := Form1.edUses.Text;
|
|
// ExeId:= '';
|
|
// SymbolType:= stDwarfSet;
|
|
// ExtraOpts:= '';
|
|
// NamePostFix:= ''
|
|
// end;
|
|
// DoOneRun('stabsSet', [AUsesDir]);
|
|
// end;
|
|
//
|
|
// if (stDwarf3 in CompilerInfo.SymbolTypes) and (stDwarf3 in DebuggerInfo.SymbolTypes)
|
|
// then begin
|
|
// with AUsesDir do begin
|
|
// DirName := Form1.edUses.Text;
|
|
// ExeId:= '';
|
|
// SymbolType:= stDwarf3;
|
|
// ExtraOpts:= '';
|
|
// NamePostFix:= ''
|
|
// end;
|
|
// DoOneRun('stDwarf3', [AUsesDir]);
|
|
// end;
|
|
|
|
|
|
end
|
|
else
|
|
DoOneRun('', []);
|
|
end;
|
|
|
|
{ TForm1 }
|
|
|
|
procedure TForm1.BtnRunClick(Sender: TObject);
|
|
var
|
|
Dummy: TTestResult;
|
|
i: Integer;
|
|
begin
|
|
edPasHistory.AddHistoryItem
|
|
(edPasFile.Text + '*' + edBreakFile.Text + '*' + edBreakLine.Text + '*' + edUses.Text + '*' + EdDefine.Text,
|
|
15, True, False);
|
|
edPasHistory.Items.SaveToFile(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt');
|
|
|
|
FResultList:= TStringMap.Create;
|
|
FResultList.Sorted := True;
|
|
|
|
if Memo2.Lines.Count > 0 then begin;
|
|
Memo2.Lines.Add('');
|
|
Memo2.Lines.Add('----- ***** ----- ***** ----- ***** -----');
|
|
Memo2.Lines.Add('');
|
|
end;
|
|
|
|
if Form1.chkCSF.Checked then begin
|
|
Form1.AppendToMemo2(LineEnding + '"-","');
|
|
for i := 0 to Form1.Memo1.Lines.Count - 1 do begin
|
|
Form1.AppendToMemo2(EscQ(Trim(Form1.Memo1.Lines[i])) + '","');
|
|
end;
|
|
Form1.AppendToMemo2('"' + LineEnding);
|
|
end;
|
|
|
|
Dummy := TTestResult.Create;
|
|
GetTestRegistry.Run(Dummy);
|
|
Dummy.Free;
|
|
|
|
//for i := 0 to FTests.Count - 1 do
|
|
//RunTest(TTest(FTests[i]), AResult);
|
|
|
|
Form1.Caption := 'Done';
|
|
FreeAndNil(FResultList);
|
|
end;
|
|
|
|
procedure TForm1.edPasFileChange(Sender: TObject);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TForm1.edPasHistoryChange(Sender: TObject);
|
|
var
|
|
t: TCaption;
|
|
i: SizeInt;
|
|
begin
|
|
t := edPasHistory.Text;
|
|
i := pos('*', t)-1;
|
|
if i < 0 then i := length(t);
|
|
edPasFile.Text := copy(t, 1, i);
|
|
delete(t,1,i+1);
|
|
|
|
i := pos('*', t)-1;
|
|
if i < 0 then i := length(t);
|
|
edBreakFile.Text := copy(t, 1, i);
|
|
delete(t,1,i+1);
|
|
|
|
i := pos('*', t)-1;
|
|
if i < 0 then i := length(t);
|
|
edBreakLine.Text := copy(t, 1, i);
|
|
delete(t,1,i+1);
|
|
|
|
i := pos('*', t)-1;
|
|
if i < 0 then i := length(t);
|
|
edUses.Text := copy(t, 1, i);
|
|
delete(t,1,i+1);
|
|
|
|
EdDefine.Text := copy(t, 1, i);
|
|
end;
|
|
|
|
procedure TForm1.FormCreate(Sender: TObject);
|
|
begin
|
|
if FileExistsUTF8(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt') then
|
|
edPasHistory.Items.LoadFromFile(AppendPathDelim(ExtractFilePath(Paramstr(0))) + 'run_gdbmi_cmds.txt');
|
|
if edPasHistory.Items.Count > 0 then
|
|
edPasHistory.ItemIndex := 0;
|
|
edBreakFile.Text := ExtractFileName(edPasHistory.Text);
|
|
edBreakLine.Text := '1';
|
|
|
|
edPasHistoryChange(nil);
|
|
end;
|
|
|
|
procedure TForm1.AppendToMemo2(Txt: String);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if FDeferAppend then begin
|
|
FMemoAppendText := FMemoAppendText + Txt;
|
|
exit;
|
|
end;
|
|
|
|
i := Memo2.Lines.Count;
|
|
if (i = 0)then
|
|
Memo2.Append(Txt)
|
|
else
|
|
Memo2.Lines[i-1] := Memo2.Lines[i-1] + Txt;
|
|
end;
|
|
|
|
procedure TForm1.BitBtn1Click(Sender: TObject);
|
|
begin
|
|
if not OpenDialog1.Execute then exit;
|
|
edPasFile.Text := OpenDialog1.FileName;
|
|
edBreakFile.Text := ExtractFileName(edPasHistory.Text);
|
|
edBreakLine.Text := '1';
|
|
end;
|
|
|
|
initialization
|
|
|
|
RegisterDbgTest(TRunner);
|
|
ControlTestRunner := TestControlRegisterTest('Run');
|
|
|
|
end.
|
|
|
|
|