1{ $Id: processdebugger.pp 61614 2019-07-22 10:41:53Z martin $ } 2{ ------------------------------------------------ 3 ProcessDebugger.pp - Debugger class which only 4 executes a target 5 ------------------------------------------------ 6 7 @created(Sun Nov 27st WET 2005) 8 @lastmod($Date: 2019-07-22 12:41:53 +0200 (Mo, 22 Jul 2019) $) 9 @author(Marc Weustink <marc@@dommelstein.net>) 10 11 This unit contains the process debugger class. It simply creates a process. 12 13 14 *************************************************************************** 15 * * 16 * This source is free software; you can redistribute it and/or modify * 17 * it under the terms of the GNU General Public License as published by * 18 * the Free Software Foundation; either version 2 of the License, or * 19 * (at your option) any later version. * 20 * * 21 * This code is distributed in the hope that it will be useful, but * 22 * WITHOUT ANY WARRANTY; without even the implied warranty of * 23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * 24 * General Public License for more details. * 25 * * 26 * A copy of the GNU General Public License is available on the World * 27 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also * 28 * obtain it by writing to the Free Software Foundation, * 29 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. * 30 * * 31 *************************************************************************** 32} 33unit ProcessDebugger; 34 35{$mode objfpc} 36{$H+} 37 38interface 39 40uses 41 Classes, SysUtils, FileUtil, UTF8Process, LazFileUtils, DbgIntfDebuggerBase, 42 Process, Debugger, LCLProc, BaseDebugManager, Dialogs, ProcessList; 43 44type 45 46 { TProcessDebugger } 47 48 TProcessDebugger = class(TDebugger) 49 private 50 FProcess: TProcessUTF8; 51 procedure ProcessDestroyed(Sender: TObject); 52 function ProcessEnvironment(const {%H-}AVariable: String; const {%H-}ASet: Boolean): Boolean; 53 function ProcessRun: Boolean; 54 function ProcessStop: Boolean; 55 protected 56 function GetSupportedCommands: TDBGCommands; override; 57 function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const; 58 const {%H-}ACallback: TMethod): Boolean; override; 59 public 60 class function Caption: String; override; 61 class function NeedsExePath: boolean; override; 62 published 63 end; 64 65implementation 66 67type 68 69 { TDBGProcess } 70 71 TDBGProcess = class(TProcessUTF8) 72 private 73 FOnDestroy: TNotifyEvent; 74 protected 75 public 76 destructor Destroy; override; 77 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; 78 end; 79 80{ TDBGProcess } 81 82destructor TDBGProcess.Destroy; 83begin 84 if Assigned(FOnDestroy) then FOnDestroy(Self); 85 inherited Destroy; 86end; 87 88 89{ TProcessDebugger } 90 91procedure TProcessDebugger.ProcessDestroyed(Sender: TObject); 92begin 93 FProcess := nil; 94 95 LockRelease; 96 try 97 if State <> dsIdle then 98 SetState(dsStop); 99 finally 100 UnlockRelease; 101 end; 102end; 103 104function TProcessDebugger.ProcessEnvironment(const AVariable: String; const ASet: Boolean): Boolean; 105begin 106 // We don't have to do anything, we'll use the Environment when running 107 Result := True; 108end; 109 110function TProcessDebugger.ProcessRun: Boolean; 111begin 112 DebugLn('PR: %s %s', [FileName, Arguments]); 113 114 if FProcess <> nil 115 then begin 116 MessageDlg('Debugger', Format('There is already a process running: %s', [FProcess.{%H-}CommandLine]), mtError, [mbOK], 0); 117 Result := False; 118 Exit; 119 end; 120 121 SetState(dsInit); 122 FProcess := TDBGProcess.Create(nil); 123 try 124 TDBGProcess(FProcess).OnDestroy := @ProcessDestroyed; 125 GetDefaultProcessList.Add(FProcess); 126 127 FProcess.Executable := FileName; 128 SplitCmdLineParams(Arguments,FProcess.Parameters); 129 FProcess.CurrentDirectory := WorkingDir; 130 FProcess.Environment.Assign(Environment); 131 if ShowConsole 132 then FProcess.Options:= [poNewConsole] 133 else FProcess.Options:= [poNoConsole]; 134 FProcess.ShowWindow := swoShowNormal; 135 FProcess.Execute; 136 except 137 on E: exception do begin 138 MessageDlg('Debugger', Format('Exception while creating process: %s', [E.Message]), mtError, [mbOK], 0); 139 Result := False; 140 SetState(dsIdle); 141 Exit; 142 end; 143 end; 144 145 SetState(dsRun); 146 Result := True; 147end; 148 149function TProcessDebugger.ProcessStop: Boolean; 150begin 151 FProcess.Terminate(0); 152 // Do not free the process, the processlist will free it 153 // FreeAndNil(FProcess); 154 155 // SetState(dsStop); 156 Result := True; 157end; 158 159function TProcessDebugger.GetSupportedCommands: TDBGCommands; 160begin 161 Result := [dcRun, dcStop, dcEnvironment] 162end; 163 164function TProcessDebugger.RequestCommand(const ACommand: TDBGCommand; 165 const AParams: array of const; const ACallback: TMethod): Boolean; 166begin 167 case ACommand of 168 dcRun: Result := ProcessRun; 169 dcStop: Result := ProcessStop; 170 dcEnvironment: Result := ProcessEnvironment(String(APArams[0].VAnsiString), AParams[1].VBoolean); 171 else Result := False; 172 end; 173end; 174 175class function TProcessDebugger.Caption: String; 176begin 177 Result := '(none)'; 178end; 179 180class function TProcessDebugger.NeedsExePath: boolean; 181begin 182 Result := false; // no need to have a valid exe path for the process debugger 183end; 184 185initialization 186 RegisterDebugger(TProcessDebugger); 187 188end. 189