1 { $Id$ }
2 { ----------------------------------------------
3 SSHGDBDebugger.pp - Debugger class for GDB
4 through SSH
5 ----------------------------------------------
6
7 @created(Wed Jul 23rd WET 2003)
8 @lastmod($Date$)
9 @author(Marc Weustink <marc@@lazarus.dommelstein.net>)
10
11 This unit contains the debugger class for the GDB/MI debugger through SSH.
12
13 ***************************************************************************
14 * *
15 * This source is free software; you can redistribute it and/or modify *
16 * it under the terms of the GNU General Public License as published by *
17 * the Free Software Foundation; either version 2 of the License, or *
18 * (at your option) any later version. *
19 * *
20 * This code is distributed in the hope that it will be useful, but *
21 * WITHOUT ANY WARRANTY; without even the implied warranty of *
22 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
23 * General Public License for more details. *
24 * *
25 * A copy of the GNU General Public License is available on the World *
26 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
27 * obtain it by writing to the Free Software Foundation, *
28 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
29 * *
30 ***************************************************************************
31 }
32 unit SSHGDBMIDebugger;
33
34 {$mode objfpc}
35 {$H+}
36
37 interface
38
39 uses
40 Classes, SysUtils,
41 // LCL
42 Dialogs, Controls, Graphics,
43 // LazUtils
44 LazStringUtils,
45 // IdeIntf
46 PropEdits,
47 // DebuggerIntf
48 DbgIntfDebuggerBase,
49 // LazDebuggerGdbmi
50 GDBMIDebugger, GdbmiStringConstants;
51
52 type
53
54 { TSSHGDBMIDebugger }
55
56 TSSHGDBMIDebugger = class(TGDBMIDebuggerBase)
57 private
58 protected
ParseInitializationnull59 function ParseInitialization: Boolean; override;
CreateDebugProcessnull60 function CreateDebugProcess(const AOptions: String): Boolean; override;
61 public
CreatePropertiesnull62 class function CreateProperties: TDebuggerProperties; override; // Creates debuggerproperties
Captionnull63 class function Caption: String; override;
ExePathsnull64 class function ExePaths: String; override;
65 (* TODO: workaround for http://bugs.freepascal.org/view.php?id=21834 *)
RequiresLocalExecutablenull66 class function RequiresLocalExecutable: Boolean; override;
67 end;
68
69 { TSSHGDBMIDebuggerProperties }
70
71 TSSHGDBMIDebuggerProperties = class(TGDBMIDebuggerPropertiesBase)
72 private
73 FAppendGDBtoSSHopt: Boolean;
74 FNote: String; //dummy
75 FRemoteGDBExe: String;
76 FSSHStartupOptions: String;
77 FSSH_TimeOut: Integer;
78 procedure SetSSH_TimeOut(AValue: Integer);
79 public
80 constructor Create; override;
81 procedure Assign(Source: TPersistent); override;
82 published
83 property Note: String read FNote write FNote;
84 property SSH_Startup_Options: String read FSSHStartupOptions write FSSHStartupOptions;
85 property SSH_TimeOut: Integer read FSSH_TimeOut write SetSSH_TimeOut default 30;
86 property Remote_GDB_Exe: String read FRemoteGDBExe write FRemoteGDBExe;
87 property Append_GDB_to_SSH_opt: Boolean read FAppendGDBtoSSHopt write FAppendGDBtoSSHopt;
88 published
89 property Debugger_Startup_Options;
90 {$IFDEF UNIX}
91 property ConsoleTty;
92 {$ENDIF}
93 property MaxDisplayLengthForString;
94 property MaxDisplayLengthForStaticArray;
95 property MaxLocalsLengthForStaticArray;
96 property TimeoutForEval;
97 property WarnOnTimeOut;
98 property WarnOnInternalError;
99 property EncodeCurrentDirPath;
100 property EncodeExeFileName;
101 property EncodingForEnvironment;
102 property EncodingForExeArgs;
103 property EncodingForExeFileName;
104 property EncodingForCurrentDirPath;
105 property InternalStartBreak;
106 property UseNoneMiRunCommands;
107 property DisableLoadSymbolsForLibraries;
108 property DisableForcedBreakpoint;
109 //property WarnOnSetBreakpointError;
110 property CaseSensitivity;
111 property GdbValueMemLimit;
112 property GdbLocalsValueMemLimit;
113 property AssemblerStyle;
114 property DisableStartupShell;
115 property FixStackFrameForFpcAssert;
116 property FixIncorrectStepOver;
117 property InternalExceptionBreakPoints;
118 property InternalExceptionBrkSetMethod;
119 end;
120
121 procedure Register;
122
123 implementation
124
125 type
126
127 { TSSHGDBMINotePropertyEditor }
128
129 TSSHGDBMINotePropertyEditor = class(TStringPropertyEditor)
130 private
131 protected
132 public
GetAttributesnull133 function GetAttributes: TPropertyAttributes; override;
GetValuenull134 function GetValue: ansistring; override;
135 procedure SetValue(const {%H-}NewValue: ansistring); override;
136 procedure PropMeasureHeight(const {%H-}NewValue: ansistring; {%H-}ACanvas:TCanvas;
137 var AHeight:Integer); override;
138 procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
139 {%H-}AState: TPropEditDrawState); override;
140 end;
141
142 { TSSHGDBMIDebuggerProperties }
143
144 procedure TSSHGDBMIDebuggerProperties.SetSSH_TimeOut(AValue: Integer);
145 begin
146 if FSSH_TimeOut = AValue then Exit;
147 If AValue < 0 then AValue := 0;
148 FSSH_TimeOut := AValue;
149 end;
150
151 constructor TSSHGDBMIDebuggerProperties.Create;
152 begin
153 inherited Create;
154 FRemoteGDBExe := 'gdb';
155 FSSHStartupOptions := '';
156 SSH_TimeOut := 30;
157 FAppendGDBtoSSHopt := False;
158 UseAsyncCommandMode := True;
159 end;
160
161 procedure TSSHGDBMIDebuggerProperties.Assign(Source: TPersistent);
162 begin
163 inherited Assign(Source);
164 if Source is TSSHGDBMIDebuggerProperties then begin
165 FRemoteGDBExe := TSSHGDBMIDebuggerProperties(Source).FRemoteGDBExe;
166 FSSHStartupOptions := TSSHGDBMIDebuggerProperties(Source).FSSHStartupOptions;
167 FSSH_TimeOut := TSSHGDBMIDebuggerProperties(Source).FSSH_TimeOut;
168 FAppendGDBtoSSHopt := TSSHGDBMIDebuggerProperties(Source).FAppendGDBtoSSHopt;
169 UseAsyncCommandMode := True;
170 end;
171 end;
172
173 { TSSHGDBMINotePropertyEditor }
174
GetAttributesnull175 function TSSHGDBMINotePropertyEditor.GetAttributes: TPropertyAttributes;
176 begin
177 Result := [paReadOnly];
178 end;
179
TSSHGDBMINotePropertyEditor.GetValuenull180 function TSSHGDBMINotePropertyEditor.GetValue: ansistring;
181 begin
182 Result := Format(lisNewTheGNUDebuggerThroughSshAllowsToRemoteDebugViaASsh, []);
183 end;
184
185 procedure TSSHGDBMINotePropertyEditor.PropMeasureHeight(const NewValue: ansistring; ACanvas: TCanvas; var AHeight: Integer);
186 begin
187 AHeight := 100;
188 end;
189
190 procedure TSSHGDBMINotePropertyEditor.PropDrawValue(ACanvas: TCanvas;
191 const ARect: TRect; AState: TPropEditDrawState);
192 var
193 Style : TTextStyle;
194 begin
195 FillChar(Style{%H-},SizeOf(Style),0);
196 With Style do begin
197 Alignment := taLeftJustify;
198 Layout := tlTop;
199 Opaque := False;
200 Clipping := True;
201 ShowPrefix := True;
202 WordBreak := True;
203 SingleLine := False;
204 ExpandTabs := True;
205 SystemFont := False;
206 end;
207 ACanvas.TextRect(ARect,ARect.Left+3,ARect.Top,GetVisualValue, Style);
208 end;
209
210 procedure TSSHGDBMINotePropertyEditor.SetValue (const NewValue: ansistring);
211 begin
212 // cannot write to note
213 end;
214
215
216 { TSSHGDBMIDebugger }
217
TSSHGDBMIDebugger.Captionnull218 class function TSSHGDBMIDebugger.Caption: String;
219 begin
220 Result := 'GNU debugger through SSH (gdb)';
221 end;
222
TSSHGDBMIDebugger.CreatePropertiesnull223 class function TSSHGDBMIDebugger.CreateProperties: TDebuggerProperties;
224 begin
225 Result := TSSHGDBMIDebuggerProperties.Create;
226 end;
227
TSSHGDBMIDebugger.ExePathsnull228 class function TSSHGDBMIDebugger.ExePaths: String;
229 begin
230 Result := '/usr/bin/ssh user@remote /usr/bin/gdb';
231 end;
232
TSSHGDBMIDebugger.RequiresLocalExecutablenull233 class function TSSHGDBMIDebugger.RequiresLocalExecutable: Boolean;
234 begin
235 Result := False;
236 end;
237
ParseInitializationnull238 function TSSHGDBMIDebugger.ParseInitialization: Boolean;
239
CheckReadLinenull240 function CheckReadLine(out ALine: String): Boolean;
241 // does a checked read
242 // returns True if we should process it
243 // returns False if it is the gdb prompt
244 begin
245 ALine := ReadLine(True, 250);
246 Result := (Pos('(gdb) ', ALine) <> 1) and
247 (pos('=thread-group-added', ALine) <> 1);
248 if Result and (ALine <> '')
249 then ALine := StripLN(ReadLine);
250 end;
251
252 var
253 t, maxT: QWord;
254
IsTimeOutnull255 function IsTimeOut: Boolean;
256 var
257 t2, t3: QWord;
258 begin
259 if maxT = 0 then exit(False);
260 t2 := GetTickCount64;
261 if t2 < t
262 then t3 := t2 + (High(t) - t)
263 else t3 := t2 - t;
264 Result := (t3 div 1000) > maxT;
265 end;
266
267 var
268 Line, ExtraText: String;
269 NotGDB, WasTimeOut: Boolean;
270 begin
271 Result := False;
272 t := GetTickCount64;
273 maxT := TSSHGDBMIDebuggerProperties(GetProperties).SSH_TimeOut;
274
275 // strip leading empty lines
276 NotGDB := CheckReadLine(Line);
277 while (not IsTimeOut) and NotGDB and (Line = '') and
278 (State <> dsError) and DebugProcessRunning
279 do
280 NotGDB := CheckReadLine(Line);;
281
282 // succesfull login ?
283 while (not IsTimeOut) and NotGDB and (Pos('try again', Line) > 0) do
284 NotGDB := CheckReadLine(Line);
285
286 (*
287 if Pos('authenticity', Line) > 0
288 then begin
289 //
290 S := Line + LineEnding + ReadLine + ReadLine;
291 if MessageDlg('Debugger', S, mtConfirmation, [mbYes, mbNo], 0) <> mrYes
292 then begin
293 SendCmdLn('no');
294 Exit;
295 end;
296 SendCmdLn('yes');
297 repeat
298 Line := StripLN(ReadLine);
299 until Pos('password:', Line) > 0
300 end;
301 *)
302
303 ExtraText := '';
304 while (not IsTimeOut) and NotGDB and (State <> dsError) and DebugProcessRunning
305 do begin
306 // No prompt yet
307 // skip known warnings
308 if (Line <> '') and
309 (pos('Pseudo-terminal will not be allocated because stdin is not a terminal', Line) <> 1)
310 then
311 ExtraText := ExtraText + LineEnding + Line;
312 NotGDB := CheckReadLine(Line);
313 end;
314
315 WasTimeOut := IsTimeOut;
316
317 if (ExtraText <> '')
318 and (MessageDlg(dlgGroupDebugger,
319 Format(lisResponseContinue, [ExtraText + LineEnding]),
320 mtConfirmation, [mbYes, mbNo], 0) <> mrYes)
321 then begin
322 // DebugProcess.Terminate(0);
323 Exit;
324 end;
325
326 if not NotGDB and (not WasTimeOut)
327 then Result := inherited ParseInitialization
328 else begin
329 // We got an unexpected result
330 if ExtraText = '' then
331 ExtraText := LineEnding + Line;
332 if WasTimeOut then
333 ExtraText := LineEnding + lisSSHDebuggerTimeout + LineEnding + ExtraText;
334 MessageDlg(dlgGroupDebugger,
335 Format(lisUnexpectedResultTheDebuggerWillTerminate, [ExtraText +
336 LineEnding]),
337 mtInformation, [mbOK], 0);
338 Exit;
339 // DebugProcess.Terminate(0);
340 end;
341 end;
342
CreateDebugProcessnull343 function TSSHGDBMIDebugger.CreateDebugProcess(const AOptions: String): Boolean;
344 var
345 p: TSSHGDBMIDebuggerProperties;
346 SshOpt: String;
347 begin
348 p := TSSHGDBMIDebuggerProperties(GetProperties);
349 SshOpt := p.FSSHStartupOptions;
350 if p.FAppendGDBtoSSHopt then begin
351 Result := inherited CreateDebugProcess(SshOpt + ' ' + p.FRemoteGDBExe + ' ' + AOptions);
352 end
353 else begin
354 Result := inherited CreateDebugProcess(SshOpt);
355 if Result then
356 SendCmdLn(p.FRemoteGDBExe + ' ' + AOptions);
357 end;
358 end;
359
360 procedure Register;
361 begin
362 RegisterPropertyEditor(TypeInfo(String), TSSHGDBMIDebuggerProperties, 'Note', TSSHGDBMINotePropertyEditor);
363 RegisterDebugger(TSSHGDBMIDebugger);
364 end;
365
366 end.
367
368
369