mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-14 03:19:32 +02:00
MWE: + Initial breakpoint support
+ Added exeption handling on process.free git-svn-id: trunk@396 -
This commit is contained in:
lazarus
parent
be5b67dcab
commit
cf74c12a01
@ -32,7 +32,7 @@ uses
|
||||
Classes, Process, Debugger{, strmlsnr};
|
||||
|
||||
type
|
||||
TCmdLineDebugger = class(TDebugger)
|
||||
TCmdLineDebugger = class(TInternalDebugger)
|
||||
private
|
||||
FTargetProcess: TProcess; // The target process to be debugged
|
||||
FDbgProcess: TProcess; // The process used to call the debugger
|
||||
@ -54,7 +54,7 @@ type
|
||||
public
|
||||
constructor Create; override;
|
||||
destructor Destroy; override;
|
||||
procedure TestCmd(const ACommand: String); // For internal debugging purposes
|
||||
procedure TestCmd(const ACommand: String); virtual;// For internal debugging purposes
|
||||
end;
|
||||
|
||||
procedure SendBreak(const AHandle: Integer);
|
||||
@ -177,7 +177,11 @@ procedure TCmdLineDebugger.CreateDebugProcess(const AName:String);
|
||||
begin
|
||||
if FDbgProcess = nil
|
||||
then begin
|
||||
FDbgProcess := TProcess.Create(AName, [poUsePipes, poNoConsole, poExecuteOnCreate]);
|
||||
FDbgProcess := TProcess.Create(nil);
|
||||
FDbgProcess.CommandLine := AName;
|
||||
FDbgProcess.Options:= [poUsePipes, poNoConsole, poStdErrToOutPut];
|
||||
FDbgProcess.ShowWindow := swoNone;
|
||||
FDbgProcess.Execute;
|
||||
WriteLn('[TCmdLineDebugger] Debug PID: ', FDbgProcess.Handle);
|
||||
GetOutput;
|
||||
end;
|
||||
@ -187,15 +191,27 @@ procedure TCmdLineDebugger.CreateTargetProcess(const AName:String);
|
||||
begin
|
||||
// TODO: Better cleanup
|
||||
FTargetProcess.Free;
|
||||
FTargetProcess := TProcess.Create(AName, [poUsePipes, poNoConsole, poExecuteOnCreate, poRunSuspended]);
|
||||
FTargetProcess := TProcess.Create(nil);
|
||||
FTargetProcess.CommandLine := AName;
|
||||
FTargetProcess.Options:= [poUsePipes, poNoConsole, poRunSuspended, poStdErrToOutPut];
|
||||
FTargetProcess.ShowWindow := swoNone;
|
||||
FTargetProcess.Execute;
|
||||
WriteLN('[TCmdLineDebugger] Target PID = ', FTargetProcess.Handle);
|
||||
end;
|
||||
|
||||
destructor TCmdLineDebugger.Destroy;
|
||||
begin
|
||||
inherited;
|
||||
FDbgProcess.Free;
|
||||
FTargetProcess.Free;
|
||||
try
|
||||
FTargetProcess.Free;
|
||||
except
|
||||
on E: Exception do WriteLN('Exeption while freeing target: ', E.Message);
|
||||
end;
|
||||
try
|
||||
FDbgProcess.Free;
|
||||
except
|
||||
on E: Exception do WriteLN('Exeption while freeing debugger: ', E.Message);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCmdLineDebugger.GetOutput;
|
||||
@ -271,7 +287,11 @@ procedure TCmdLineDebugger.KillTargetProcess;
|
||||
begin
|
||||
FTargetProcess.Terminate(0);
|
||||
FTargetProcess.WaitOnExit;
|
||||
FTargetProcess.Free;
|
||||
try
|
||||
FTargetProcess.Free;
|
||||
except
|
||||
on E: Exception do WriteLN('Exeption while freeing target: ', E.Message);
|
||||
end;
|
||||
FTargetProcess:= nil;
|
||||
end;
|
||||
|
||||
@ -302,6 +322,10 @@ end;
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.2 2001/11/06 23:59:12 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.1 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
@ -31,40 +31,51 @@ uses
|
||||
type
|
||||
TDBGBreakPointActions = (bpaStop, bpaEnableGroup, bpaDisableGroup);
|
||||
|
||||
|
||||
TDBGBreakPointGroup = class;
|
||||
|
||||
TDBGBreakPointClass = class of TDBGBreakPoint;
|
||||
TDBGBreakPoint = class(TCollectionItem)
|
||||
private
|
||||
FDebugger: TObject; // reference to our debugger
|
||||
FValid: Boolean;
|
||||
FEnabled: Boolean;
|
||||
FHitCount: Integer;
|
||||
FExpression: String;
|
||||
FExpression: String;
|
||||
FSource: String;
|
||||
FLine: Integer;
|
||||
FActions: TDBGBreakPointActions;
|
||||
procedure SetActions(const AValue: TDBGBreakPointActions);
|
||||
procedure SetEnabled(const AValue: Boolean);
|
||||
procedure SetExpression(const AValue: String);
|
||||
procedure SetHitCount(const AValue: Integer);
|
||||
procedure SetValid(const AValue: Boolean);
|
||||
protected
|
||||
procedure SetActions(const AValue: TDBGBreakPointActions);
|
||||
procedure SetEnabled(const AValue: Boolean);
|
||||
procedure SetExpression(const AValue: String);
|
||||
protected
|
||||
procedure SetHitCount(const AValue: Integer);
|
||||
procedure SetLocation(const ASource: String; const ALine: Integer); virtual;
|
||||
procedure SetValid(const AValue: Boolean);
|
||||
public
|
||||
procedure AddDisableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
procedure AddEnableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
constructor Create(ACollection: TCollection); override;
|
||||
destructor Destroy; override;
|
||||
procedure RemoveDisableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
procedure RemoveEnableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
property Actions: TDBGBreakPointActions read FActions write SetActions;
|
||||
property Enabled: Boolean read FEnabled write SetEnabled;
|
||||
property HitCount: Integer read FHitCount write SetHitCount;
|
||||
property HitCount: Integer read FHitCount;
|
||||
property Expression: String read FExpression write SetExpression;
|
||||
property Valid: Boolean read FValid write SetValid;
|
||||
property Source: String read FSource;
|
||||
property Line: Integer read FLine;
|
||||
property Valid: Boolean read FValid;
|
||||
end;
|
||||
|
||||
TDBGBreakPoints = class(TCollection)
|
||||
private
|
||||
FDebugger: TObject; // reference to our debugger
|
||||
function GetItem(const AnIndex: Integer): TDBGBreakPoint;
|
||||
procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint);
|
||||
protected
|
||||
public
|
||||
constructor Create;
|
||||
public
|
||||
constructor Create(const ADebugger: TObject);
|
||||
function Add(const ASource: String; const ALine: Integer): TDBGBreakPoint;
|
||||
property Items[const AnIndex: Integer]: TDBGBreakPoint read GetItem write SetItem; default;
|
||||
end;
|
||||
|
||||
@ -85,18 +96,22 @@ type
|
||||
end;
|
||||
|
||||
TDBGBreakPointGroups = class(TCollection)
|
||||
private
|
||||
private
|
||||
FDebugger: TObject;
|
||||
function GetItem(const AnIndex: Integer): TDBGBreakPointGroup;
|
||||
procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPointGroup);
|
||||
protected
|
||||
public
|
||||
constructor Create;
|
||||
constructor Create(const ADebugger: TObject);
|
||||
property Items[const AnIndex: Integer]: TDBGBreakPointGroup read GetItem write SetItem; default;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Debugger;
|
||||
|
||||
{ TDBGBreakPoint }
|
||||
|
||||
procedure TDBGBreakPoint.AddDisableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
@ -107,6 +122,25 @@ procedure TDBGBreakPoint.AddEnableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
begin
|
||||
end;
|
||||
|
||||
constructor TDBGBreakPoint.Create(ACollection: TCollection);
|
||||
begin
|
||||
inherited Create(ACollection);
|
||||
FSource := '';
|
||||
FLine := -1;
|
||||
FValid := False;
|
||||
FEnabled := False;
|
||||
FHitCount := 0;
|
||||
FExpression := '';
|
||||
|
||||
FDebugger := TDBGBreakPoints(ACollection).FDebugger;
|
||||
end;
|
||||
|
||||
destructor TDBGBreakPoint.Destroy;
|
||||
begin
|
||||
TInternalDebugger(FDebugger).BreakRemove(Self);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.RemoveDisableGroup(const AGroup: TDBGBreakPointGroup);
|
||||
begin
|
||||
end;
|
||||
@ -117,17 +151,29 @@ end;
|
||||
|
||||
procedure TDBGBreakPoint.SetActions(const AValue: TDBGBreakPointActions);
|
||||
begin
|
||||
FActions := AValue;
|
||||
if FActions <> AValue
|
||||
then begin
|
||||
FActions := AValue;
|
||||
TInternalDebugger(FDebugger).BreakActionChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.SetEnabled(const AValue: Boolean);
|
||||
begin
|
||||
FEnabled := AValue;
|
||||
if FEnabled <> AValue
|
||||
then begin
|
||||
FEnabled := AValue;
|
||||
TInternalDebugger(FDebugger).BreakEnableChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.SetExpression(const AValue: String);
|
||||
begin
|
||||
FExpression := AValue;
|
||||
if FExpression <> AValue
|
||||
then begin
|
||||
FExpression := AValue;
|
||||
TInternalDebugger(FDebugger).BreakExpressionChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.SetHitCount(const AValue: Integer);
|
||||
@ -135,6 +181,13 @@ begin
|
||||
FHitCount := AValue;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.SetLocation(const ASource: String; const ALine: Integer);
|
||||
begin
|
||||
FSource := ASource;
|
||||
FLine := ALine;
|
||||
TInternalDebugger(FDebugger).BreakAdd(Self);
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoint.SetValid(const AValue: Boolean);
|
||||
begin
|
||||
FValid := AValue;
|
||||
@ -142,9 +195,16 @@ end;
|
||||
|
||||
{ TDBGBreakPoints }
|
||||
|
||||
constructor TDBGBreakPoints.Create;
|
||||
function TDBGBreakPoints.Add(const ASource: String; const ALine: Integer): TDBGBreakPoint;
|
||||
begin
|
||||
Result := TDBGBreakPoint(inherited Add);
|
||||
Result.SetLocation(ASource, ALine);
|
||||
end;
|
||||
|
||||
constructor TDBGBreakPoints.Create(const ADebugger: TObject);
|
||||
begin
|
||||
inherited Create(TDBGBreakPoint);
|
||||
FDebugger := ADebugger;
|
||||
end;
|
||||
|
||||
function TDBGBreakPoints.GetItem(const AnIndex: Integer): TDBGBreakPoint;
|
||||
@ -153,7 +213,8 @@ begin
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPoints.SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint);
|
||||
begin
|
||||
begin
|
||||
SetItem(AnIndex, AValue);
|
||||
end;
|
||||
|
||||
{ TDBGBreakPointGroup }
|
||||
@ -161,10 +222,13 @@ end;
|
||||
constructor TDBGBreakPointGroup.Create(ACollection: TCollection);
|
||||
begin
|
||||
inherited Create(ACollection);
|
||||
FBreakpoints := TDBGBreakPoints.Create(TDBGBreakPointGroups(ACollection).FDebugger);
|
||||
end;
|
||||
|
||||
destructor TDBGBreakPointGroup.Destroy;
|
||||
begin
|
||||
begin
|
||||
FBreakpoints.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TDBGBreakPointGroup.SetEnabled(const AValue: Boolean);
|
||||
@ -179,9 +243,10 @@ end;
|
||||
|
||||
{ TDBGBreakPointGroups }
|
||||
|
||||
constructor TDBGBreakPointGroups.Create;
|
||||
constructor TDBGBreakPointGroups.Create(const ADebugger: TObject);
|
||||
begin
|
||||
inherited Create(TDBGBreakPointGroup);
|
||||
FDebugger := ADebugger;
|
||||
end;
|
||||
|
||||
function TDBGBreakPointGroups.GetItem(const AnIndex: Integer): TDBGBreakPointGroup;
|
||||
@ -191,11 +256,16 @@ end;
|
||||
|
||||
procedure TDBGBreakPointGroups.SetItem(const AnIndex: Integer; const AValue: TDBGBreakPointGroup);
|
||||
begin
|
||||
inherited SetItem(AnIndex, AValue);
|
||||
end;
|
||||
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.5 2001/11/06 23:59:12 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.4 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
@ -92,7 +92,7 @@ end;
|
||||
{ TDBGWatches }
|
||||
|
||||
constructor TDBGWatches.Create;
|
||||
begin
|
||||
begin
|
||||
inherited Create(TDBGWatch);
|
||||
end;
|
||||
|
||||
@ -109,6 +109,10 @@ end;
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.5 2001/11/06 23:59:13 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.4 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
@ -62,7 +62,7 @@ type
|
||||
procedure DoDbgOutput(const AText: String);
|
||||
procedure DoOutput(const AText: String);
|
||||
procedure DoState;
|
||||
function GetFlags: TDBGCommands; virtual;
|
||||
function GetFlags: TDBGCommands; virtual;
|
||||
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; virtual; abstract; // True if succesful
|
||||
procedure SetFileName(const Value: String); virtual;
|
||||
procedure SetState(const Value: TDBGState);
|
||||
@ -91,6 +91,16 @@ type
|
||||
property OnDbgOutput: TDBGOutputEvent read FOnDbgOutput write FOnDbgOutput;// Passes all debuggeroutput
|
||||
end;
|
||||
|
||||
TInternalDebugger = class(TDebugger)
|
||||
private
|
||||
protected
|
||||
public
|
||||
procedure BreakActionChange(const ABreakPoint: TDBGBreakpoint); virtual;
|
||||
procedure BreakAdd(const ABreakPoint: TDBGBreakpoint); virtual;
|
||||
procedure BreakEnableChange(const ABreakPoint: TDBGBreakpoint); virtual;
|
||||
procedure BreakExpressionChange(const ABreakPoint: TDBGBreakpoint); virtual;
|
||||
procedure BreakRemove(const ABreakPoint: TDBGBreakpoint); virtual;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
@ -119,7 +129,7 @@ begin
|
||||
FState := dsNone;
|
||||
FArguments := '';
|
||||
FFilename := '';
|
||||
FBreakPointGroups := TDBGBreakPointGroups.Create;
|
||||
FBreakPointGroups := TDBGBreakPointGroups.Create(Self);
|
||||
FWatches := TDBGWatches.Create;
|
||||
end;
|
||||
|
||||
@ -236,9 +246,36 @@ begin
|
||||
ReqCmd(dcStop, []);
|
||||
end;
|
||||
|
||||
{ TInternalDebugger }
|
||||
|
||||
procedure TInternalDebugger.BreakActionChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TInternalDebugger.BreakAdd(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TInternalDebugger.BreakEnableChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TInternalDebugger.BreakExpressionChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TInternalDebugger.BreakRemove(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.4 2001/11/06 23:59:13 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.3 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
@ -28,7 +28,7 @@ unit GDBDebugger;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Process, Debugger, CmdLineDebugger;
|
||||
Classes, Process, Debugger, CmdLineDebugger, DBGBreakPoint;
|
||||
|
||||
type
|
||||
|
||||
@ -45,6 +45,12 @@ type
|
||||
function GetGDBState: TDBGState;
|
||||
function GetLocation: TDBGLocationRec;
|
||||
protected
|
||||
procedure BreakActionChange(const ABreakPoint: TDBGBreakpoint); override;
|
||||
procedure BreakAdd(const ABreakPoint: TDBGBreakpoint); override;
|
||||
procedure BreakEnableChange(const ABreakPoint: TDBGBreakpoint); override;
|
||||
procedure BreakExpressionChange(const ABreakPoint: TDBGBreakpoint); override;
|
||||
procedure BreakRemove(const ABreakPoint: TDBGBreakpoint); override;
|
||||
|
||||
function GetFlags: TDBGCommands; override;
|
||||
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
|
||||
public
|
||||
@ -53,6 +59,8 @@ type
|
||||
|
||||
procedure Init; override; // Initializes external debugger
|
||||
procedure Done; override; // Kills external debugger
|
||||
// internal testing
|
||||
procedure TestCmd(const ACommand: String); override;
|
||||
end;
|
||||
|
||||
|
||||
@ -63,6 +71,26 @@ uses
|
||||
|
||||
{ TGDBDebugger }
|
||||
|
||||
procedure TGDBDebugger.BreakActionChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TGDBDebugger.BreakAdd(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TGDBDebugger.BreakEnableChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TGDBDebugger.BreakExpressionChange(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TGDBDebugger.BreakRemove(const ABreakPoint: TDBGBreakpoint);
|
||||
begin
|
||||
end;
|
||||
|
||||
constructor TGDBDebugger.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
@ -144,14 +172,12 @@ begin
|
||||
end;
|
||||
|
||||
dState := GetGDBState;
|
||||
if dState = dsRun
|
||||
if dState <> dsPause
|
||||
then Exit;
|
||||
|
||||
if dState = dsPause
|
||||
then begin
|
||||
SendCmdLn('kill', True);
|
||||
dState := GetGDBState;
|
||||
end;
|
||||
|
||||
SendCmdLn('kill', True);
|
||||
dState := GetGDBState;
|
||||
|
||||
if dState = dsStop
|
||||
then KillTargetProcess;
|
||||
SetState(dState);
|
||||
@ -168,6 +194,7 @@ var
|
||||
begin
|
||||
SendCmdLn('info program', True);
|
||||
S := OutputLines.Text;
|
||||
WriteLn('Info: ',S);
|
||||
if Pos('stopped', S) > 0
|
||||
then Result := dsPause
|
||||
else if Pos('not being run', S) > 0
|
||||
@ -254,9 +281,21 @@ begin
|
||||
SetState(GetGDBState);
|
||||
end;
|
||||
|
||||
procedure TGDBDebugger.TestCmd(const ACommand: String);
|
||||
begin
|
||||
SetState(dsRun);
|
||||
inherited TestCmd(ACommand);
|
||||
DoCurrent(GetLocation);
|
||||
SetState(GetGDBState);
|
||||
end;
|
||||
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.2 2001/11/06 23:59:13 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.1 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
@ -117,8 +117,11 @@ begin
|
||||
FDebugger.OnOutput := @DBGTargetOutput;
|
||||
FDebugger.OnCurrent := @DBGCurrent;
|
||||
FDebugger.OnState := @DBGState;
|
||||
|
||||
FOutputForm := TDBGOutputForm.Create(nil);
|
||||
|
||||
// Something strange going on here,
|
||||
// sometimes the form crashes during load with Application as owner
|
||||
// sometimes the form crashes during load with nil as owner
|
||||
FOutputForm := TDBGOutputForm.Create(Application);
|
||||
FOutputForm.OnDestroy := @OutputFormDestroy;
|
||||
FOutputForm.Show;
|
||||
end;
|
||||
@ -230,6 +233,10 @@ initialization
|
||||
end.
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.2 2001/11/06 23:59:13 lazarus
|
||||
MWE: + Initial breakpoint support
|
||||
+ Added exeption handling on process.free
|
||||
|
||||
Revision 1.1 2001/11/05 00:12:51 lazarus
|
||||
MWE: First steps of a debugger.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user