paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-13 11:29:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

FpDebug: Allow to specify poNewConsole on windows

Browse Source 
git-svn-id: trunk@59488 -
This commit is contained in:
martin 2018-11-07 23:13:11 +00:00
parent 96746c2c7c
commit c54639d227
6 changed files with 43 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
components/fpdebug/fpdbgclasses.pp
View File

@ -269,6 +269,9 @@ type
property BaseAddr: TDBGPtr read FBaseAddr;
end;
TStartInstanceFlag = (siRediretOutput, siForceNewConsole);
TStartInstanceFlags = set of TStartInstanceFlag;
{ TDbgProcess }
TDbgProcess = class(TDbgInstance)
@ -305,7 +308,7 @@ type
// Should analyse why the debugger has stopped.
function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; virtual; abstract;
public
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess; virtual;
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; AFlags: TStartInstanceFlags): TDbgProcess; virtual;
constructor Create(const AFileName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); virtual;
destructor Destroy; override;
function AddBreak(const ALocation: TDBGPtr): TFpInternalBreakpoint; overload;
@ -1086,8 +1089,9 @@ end;
resourcestring
sNoDebugSupport = 'Debug support is not available for this platform .';
class function TDbgProcess.StartInstance(AFileName: string; AParams,
AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess;
class function TDbgProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings;
AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog;
AFlags: TStartInstanceFlags): TDbgProcess;
begin
if assigned(AOnLog) then
AOnLog(sNoDebugSupport, dllError)

9
components/fpdebug/fpdbgcontroller.pas
View File

@ -129,6 +129,7 @@ type
private
FEnvironment: TStrings;
FExecutableFilename: string;
FForceNewConsoleWin: boolean;
FNextOnlyStopOnStartLine: boolean;
FOnCreateProcessEvent: TOnCreateProcessEvent;
FOnDebugInfoLoaded: TNotifyEvent;
@ -179,6 +180,7 @@ type
property Environment: TStrings read FEnvironment write SetEnvironment;
property WorkingDirectory: string read FWorkingDirectory write FWorkingDirectory;
property RedirectConsoleOutput: boolean read FRedirectConsoleOutput write FRedirectConsoleOutput;
property ForceNewConsoleWin: boolean read FForceNewConsoleWin write FForceNewConsoleWin; // windows only
property ConsoleTty: string read FConsoleTty write FConsoleTty;
// With this parameter set a 'next' will only stop if the current
// instruction is the first instruction of a line according to the
@ -641,6 +643,8 @@ begin
end;
function TDbgController.Run: boolean;
var
Flags: TStartInstanceFlags;
begin
result := False;
if assigned(FMainProcess) then
@ -661,7 +665,10 @@ begin
Exit;
end;
FCurrentProcess := OSDbgClasses.DbgProcessClass.StartInstance(FExecutableFilename, Params, Environment, WorkingDirectory, FConsoleTty , @Log, RedirectConsoleOutput);
Flags := [];
if RedirectConsoleOutput then Include(Flags, siRediretOutput);
if ForceNewConsoleWin then Include(Flags, siForceNewConsole);
FCurrentProcess := OSDbgClasses.DbgProcessClass.StartInstance(FExecutableFilename, Params, Environment, WorkingDirectory, FConsoleTty , @Log, Flags);
if assigned(FCurrentProcess) then
begin
FProcessMap.Add(FCurrentProcess.ProcessID, FCurrentProcess);

8
components/fpdebug/fpdbgdarwinclasses.pas
View File

@ -144,7 +144,7 @@ type
function CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; override;
function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override;
public
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess; override;
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; AFlags: TStartInstanceFlags): TDbgProcess; override;
constructor Create(const AName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); override;
destructor Destroy; override;
@ -698,7 +698,9 @@ begin
inherited Destroy;
end;
class function TDbgDarwinProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess;
class function TDbgDarwinProcess.StartInstance(AFileName: string; AParams,
AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog;
AFlags: TStartInstanceFlags): TDbgProcess;
var
PID: TPid;
AProcess: TProcessUTF8;
@ -725,7 +727,7 @@ begin
end;
AMasterPtyFd:=-1;
if ReDirectOutput then
if siRediretOutput in AFlags then
begin
if AConsoleTty<>'' then
AOnLog('It is of no use to provide a console-tty when the console output is being redirected.', dllInfo);

8
components/fpdebug/fpdbglinuxclasses.pas
View File

@ -264,7 +264,9 @@ type
function CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; override;
function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override;
public
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess; override;
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings;
AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog;
AFlags: TStartInstanceFlags): TDbgProcess; override;
constructor Create(const AName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); override;
destructor Destroy; override;
@ -615,7 +617,7 @@ begin
end;
class function TDbgLinuxProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string;
AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess;
AOnLog: TOnLog; AFlags: TStartInstanceFlags): TDbgProcess;
var
PID: TPid;
AProcess: TProcessUTF8;
@ -638,7 +640,7 @@ begin
end;
AMasterPtyFd:=-1;
if ReDirectOutput then
if siRediretOutput in AFlags then
begin
if AConsoleTty<>'' then
AOnLog('It is of no use to provide a console-tty when the console output is being redirected.', dllInfo);

9
components/fpdebug/fpdbgwinclasses.pas
View File

@ -109,7 +109,7 @@ type
procedure Interrupt;
function HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess; override;
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; AFlags: TStartInstanceFlags): TDbgProcess; override;
function Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean; override;
function WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; override;
function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override;
@ -458,8 +458,9 @@ begin
end;
end;
class function TDbgWinProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string;
AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess;
class function TDbgWinProcess.StartInstance(AFileName: string; AParams,
AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog;
AFlags: TStartInstanceFlags): TDbgProcess;
var
AProcess: TProcessUTF8;
begin
@ -467,6 +468,8 @@ begin
AProcess := TProcessUTF8.Create(nil);
try
AProcess.Options:=[poDebugProcess, poNewProcessGroup];
if siForceNewConsole in AFlags then
AProcess.Options:=AProcess.Options+[poNewConsole];
AProcess.Executable:=AFilename;
AProcess.Parameters:=AParams;
AProcess.Environment:=AnEnvironment;

12
components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
View File

@ -61,6 +61,9 @@ type
TFpDebugDebuggerProperties = class(TDebuggerProperties)
private
FConsoleTty: string;
{$ifdef windows}
FForceNewConsole: boolean;
{$endif windows}
FNextOnlyStopOnStartLine: boolean;
public
constructor Create; override;
@ -71,6 +74,9 @@ type
property ConsoleTty: string read FConsoleTty write FConsoleTty;
published
property NextOnlyStopOnStartLine: boolean read FNextOnlyStopOnStartLine write FNextOnlyStopOnStartLine;
{$ifdef windows}
property ForceNewConsole: boolean read FForceNewConsole write FForceNewConsole;
{$endif windows}
end;
{ TFpDebugDebugger }
@ -417,6 +423,9 @@ begin
if Source is TFpDebugDebuggerProperties then begin
FNextOnlyStopOnStartLine := TFpDebugDebuggerProperties(Source).NextOnlyStopOnStartLine;
FConsoleTty:=TFpDebugDebuggerProperties(Source).ConsoleTty;
{$ifdef windows}
FForceNewConsole:=TFpDebugDebuggerProperties(Source).FForceNewConsole;
{$endif windows}
end;
end;
@ -1664,6 +1673,9 @@ begin
CommandToList(Arguments, FDbgController.Params);
FDbgController.WorkingDirectory:=WorkingDir;
FDbgController.Environment:=Environment;
{$ifdef windows}
FDbgController.ForceNewConsoleWin:=TFpDebugDebuggerProperties(GetProperties).ForceNewConsole;
{$endif windows}
FFpDebugThread := TFpDebugThread.Create(Self);
RTLeventWaitFor(FFpDebugThread.DebugLoopStoppedEvent);
RTLeventResetEvent(FFpDebugThread.DebugLoopStoppedEvent);