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