1 unit FPDServerDebugger;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, strutils, SysUtils, ssockets, fgl, process, syncobjs, fpjson,
9 forms, dialogs,
10 DbgIntfDebuggerBase, DbgIntfBaseTypes,
11 // jsonparser,
12 {$IFDEF UNIX}
13 BaseUnix,
14 {$ENDIF}
15 LazLoggerBase, lazCollections, LazSysUtils, LazStringUtils, UTF8Process, maps;
16
17 type
18 TThreadedQueueString = specialize TLazThreadedQueue<string>;
19 TFPDServerDebugger = class;
20
21 { TFPDSendCommand }
22
23 TFPDSendCommand = class
24 protected
25 FCommandUID: integer;
26 FServerDebugger: TFPDServerDebugger;
27 FAutomaticFree: boolean;
GetAsStringnull28 function GetAsString: string; virtual;
29 procedure ComposeJSon(AJsonObject: TJSONObject); virtual;
30 public
31 constructor create(AnAutomaticFree: boolean=true); virtual;
32 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); virtual;
33 procedure DoOnCommandReceived(ACommandResponse: TJSonObject); virtual;
34 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); virtual;
35 property CommandUID: integer read FCommandUID;
36 property AsString: string read GetAsString;
37 property AutomaticFree: boolean read FAutomaticFree;
38 end;
39
40 { TFPDSendCommandList }
41
42 TFPDCustomSendCommandList = specialize TFPGObjectList<TFPDSendCommand>;
43 TFPDSendCommandList = class(TFPDCustomSendCommandList)
44 public
SearchByUIDnull45 function SearchByUID(const ACommandUID: integer): TFPDSendCommand;
46 end;
47
48 { TFPDSendQuitDebugServerCommand }
49
50 TFPDSendQuitDebugServerCommand = class(TFPDSendCommand)
51 protected
52 procedure ComposeJSon(AJsonObject: TJSONObject); override;
53 end;
54
55 { TFPDSendRunCommand }
56
57 TFPDSendRunCommand = class(TFPDSendCommand)
58 protected
59 procedure ComposeJSon(AJsonObject: TJSONObject); override;
60 public
61 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
62 end;
63
64 { TFPDSendContinueCommand }
65
66 TFPDSendContinueCommand = class(TFPDSendCommand)
67 protected
68 procedure ComposeJSon(AJsonObject: TJSONObject); override;
69 public
70 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
71 end;
72
73 { TFPDSendNextCommand }
74
75 TFPDSendNextCommand = class(TFPDSendCommand)
76 protected
77 procedure ComposeJSon(AJsonObject: TJSONObject); override;
78 end;
79
80 { TFPDSendStepCommand }
81
82 TFPDSendStepCommand = class(TFPDSendCommand)
83 protected
84 procedure ComposeJSon(AJsonObject: TJSONObject); override;
85 end;
86
87 { TFPDSendStepIntoInstrCommand }
88
89 TFPDSendStepIntoInstrCommand = class(TFPDSendCommand)
90 protected
91 procedure ComposeJSon(AJsonObject: TJSONObject); override;
92 end;
93
94 { TFPDSendStepOverInstrCommand }
95
96 TFPDSendStepOverInstrCommand = class(TFPDSendCommand)
97 protected
98 procedure ComposeJSon(AJsonObject: TJSONObject); override;
99 end;
100
101 { TFPDSendStopCommand }
102
103 TFPDSendStopCommand = class(TFPDSendCommand)
104 protected
105 procedure ComposeJSon(AJsonObject: TJSONObject); override;
106 end;
107
108 { TFPDSendStepOutCommand }
109
110 TFPDSendStepOutCommand = class(TFPDSendCommand)
111 protected
112 procedure ComposeJSon(AJsonObject: TJSONObject); override;
113 end;
114
115 { TFPDSendFilenameCommand }
116
117 TFPDSendFilenameCommand = class(TFPDSendCommand)
118 private
119 FFileName: string;
120 protected
121 procedure ComposeJSon(AJsonObject: TJSONObject); override;
122 public
123 constructor create(AFileName: string); virtual;
124 end;
125
126 { TFPDSendAddBreakpointCommand }
127
128 TFPDSendAddBreakpointCommand = class(TFPDSendCommand)
129 private
130 FFileName: string;
131 FLineNr: integer;
132 FLocation: TDBGPtr;
133 protected
134 procedure ComposeJSon(AJsonObject: TJSONObject); override;
135 public
136 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
137 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
138 constructor create(AFileName: string; ALineNr: integer); virtual;
139 constructor create(ALocation: TDBGPtr); virtual;
140 end;
141
142 { TFPDSendRemoveBreakpointCommand }
143
144 TFPDSendRemoveBreakpointCommand = class(TFPDSendCommand)
145 private
146 FId: Integer;
147 protected
148 procedure ComposeJSon(AJsonObject: TJSONObject); override;
149 public
150 constructor create(AnId: Integer); virtual;
151 end;
152
153 { TFPDSendDoCurrentCommand }
154
155 TFPDSendDoCurrentCommand = class(TFPDSendCommand)
156 protected
157 procedure ComposeJSon(AJsonObject: TJSONObject); override;
158 public
159 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
160 end;
161
162 { TFPDSendEvaluateCommand }
163
164 TFPDSendEvaluateCommand = class(TFPDSendCommand)
165 private
166 FExpression: string;
167 FValidity: TDebuggerDataState;
168 FMessage: string;
169 protected
170 procedure ComposeJSon(AJsonObject: TJSONObject); override;
171 public
172 constructor create(AnAutomaticFree: boolean; AnExpression: string);
173 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
174 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
175 property Validity: TDebuggerDataState read FValidity;
176 property Message: string read FMessage;
177 end;
178
179 { TFPDSendWatchEvaluateCommand }
180
181 TFPDSendWatchEvaluateCommand = class(TFPDSendCommand)
182 private
183 FWatchValue: TWatchValue;
184 procedure DoWatchFreed(Sender: TObject);
185 protected
186 procedure ComposeJSon(AJsonObject: TJSONObject); override;
187 public
188 constructor create(AWatchValue: TWatchValue);
189 destructor Destroy; override;
190 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
191 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
192 end;
193
194 { TFPDSendCallStackCommand }
195
196 TFPDSendCallStackCommand = class(TFPDSendCommand)
197 private
198 FCallStack: TCallStackBase;
199 FCallStackSupplier: TCallStackSupplier;
200 procedure DoCallStackFreed(Sender: TObject);
201 protected
202 procedure ComposeJSon(AJsonObject: TJSONObject); override;
203 public
204 constructor create(ACallStack: TCallStackBase; ACallStackSupplier: TCallStackSupplier);
205 destructor Destroy; override;
206 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
207 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
208 end;
209
210 { TFPDSendLocalsCommand }
211
212 TFPDSendLocalsCommand = class(TFPDSendCommand)
213 private
214 FLocals: TLocals;
215 procedure DoLocalsFreed(Sender: TObject);
216 protected
217 procedure ComposeJSon(AJsonObject: TJSONObject); override;
218 public
219 constructor create(ALocals: TLocals);
220 destructor Destroy; override;
221 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
222 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
223 end;
224
225 { TFPDSendRegistersCommand }
226
227 TFPDSendRegistersCommand = class(TFPDSendCommand)
228 private
229 FRegisters: TRegisters;
230 procedure DoRegistersFreed(Sender: TObject);
231 protected
232 procedure ComposeJSon(AJsonObject: TJSONObject); override;
233 public
234 constructor create(ARegisters: TRegisters);
235 destructor Destroy; override;
236 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
237 procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
238 end;
239
240 { TFPDSendDisassembleCommand }
241
242 TFPDSendDisassembleCommand = class(TFPDSendCommand)
243 private
244 FDisassembler: TDBGDisassembler;
245 FStartAddr: TDBGPtr;
246 FLinesAfter: integer;
247 FLinesBefore: integer;
248 protected
249 procedure ComposeJSon(AJsonObject: TJSONObject); override;
250 public
251 constructor create(ADisassembler: TDBGDisassembler; AStartAddr: TDBGPtr; ALinesBefore, ALinesAfter: integer);
252 procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
253 end;
254
255 { TFPDSocketThread }
256
257 TFPDSocketThread = class(TThread)
258 private
259 FPort: integer;
260 FHostName: string;
261 FConnectionIdentifier: integer;
262 FDebugger: TFPDServerDebugger;
263 FSendQueue: TThreadedQueueString;
264 FErrMessage: string;
265 protected
266 procedure ReceivedCommand(Data: PtrInt);
267 procedure ConnectionProblem(Data: PtrInt);
268 procedure Execute; override;
269 public
270 constructor Create(ADebugger: TFPDServerDebugger; AHostName: string; APort: integer);
271 procedure SendString(AString: string);
272 destructor Destroy; override;
273 property ConnectionIdentifier: integer read FConnectionIdentifier;
274 end;
275
276 { TFPDServerDebugger }
277
278 TFPDServerDebugger = class(TDebuggerIntf)
279 private
280 FSocketThread: TFPDSocketThread;
281 FDebugServerStartedAsChild: boolean;
282 FIsConnected: boolean;
283 FDebugProcess: TProcessUTF8;
284 // This is a list of all commands send to the fpdebug-server, to handle the (asynchrounous)
285 // callback when a command is a succes or failure.
286 FCommandList: TFPDSendCommandList;
ConnectToFPDServernull287 function ConnectToFPDServer: boolean;
288 procedure DisconnectFromFPDServer;
289 protected
290 // Overrides of TDebuggerIntf methods.
GetSupportedCommandsnull291 class function GetSupportedCommands: TDBGCommands; override;
292 // Handle Notifications received from the FPDebug-server
293 procedure HandleNotification(ANotification: TJSONObject);
294 // Handle log-messages received from the FPDebug-server
295 procedure HandleLog(ALog: TJSONObject);
296 // Handle Events received from the FPDebug-server
297 procedure HandleEvent(ANotification: TJSONObject);
298 // Event-handlers for events received from the FPDebug-server
299 procedure DoHandleCreateProcessEvent(AnEvent: TJSONObject);
300 procedure DoHandleExitProcessEvent(AnEvent: TJSONObject);
301 procedure DoHandleBreakpointEvent(AnEvent: TJSONObject);
302 procedure DoHandleConsoleOutputEvent(AnEvent: TJSONObject);
303 public
304 constructor Create(const AExternalDebugger: String); override;
305 destructor Destroy; override;
isnull306 // This function is called (in the main thread) by the TFPDSocketThread on each JSon-object received
307 // from the FPD-Server.
308 procedure ReceivedCommand(ACommand: TJSONObject);
309 // Queue a command for sending to the FPDebug-server.
310 procedure QueueCommand(ACommand: TFPDSendCommand);
311 // Overrides of TDebuggerIntf methods.
Captionnull312 class function Caption: String; override;
CreateBreakPointsnull313 function CreateBreakPoints: TDBGBreakPoints; override;
CreateWatchesnull314 function CreateWatches: TWatchesSupplier; override;
CreateLocalsnull315 function CreateLocals: TLocalsSupplier; override;
CreateRegistersnull316 function CreateRegisters: TRegisterSupplier; override;
CreateCallStacknull317 function CreateCallStack: TCallStackSupplier; override;
CreateDisassemblernull318 function CreateDisassembler: TDBGDisassembler; override;
RequestCommandnull319 function RequestCommand(const ACommand: TDBGCommand;
320 const AParams: array of const;
321 const ACallback: TMethod): Boolean; override;
322 // These methods are called by several TFPDSendCommands after success or failure of a command. (Most common
323 // because the TFPDSendCommands do not have access to TFPDServerDebugger's protected methods theirself)
324 procedure DoOnRunFailed;
325 procedure DoOnContinueSuccessfull;
326 procedure DoOnDoCurrentSuccessfull(ALocRec: TDBGLocationRec);
327 // This procedure is called when the socket-thread is shut-down.
328 procedure DoOnConnectionProblem(AMessage: string);
329 end;
330
331 procedure Register;
332
333 implementation
334
335 type
336
337 { TFPBreakpoint }
338
339 TFPBreakpoint = class(TDBGBreakPoint)
340 private
341 FSetBreakFlag: boolean;
342 FResetBreakFlag: boolean;
343 FIsSet: boolean;
344 FUID: integer;
345 FServerId: integer;
346 procedure SetBreak;
347 procedure ResetBreak;
348 protected
349 procedure DoStateChange(const AOldState: TDBGState); override;
350 procedure DoEnableChange; override;
351 procedure DoChanged; override;
352 // Used in the succes or failure callbacks of the TFPDSendAddBreakpointCommand command to set the
353 // validity of the underlying breakpoint.
354 procedure SetValid;
355 procedure SetInvalid;
356 public
357 destructor Destroy; override;
358 property UID: integer read FUID;
359 property ServerId: Integer read FServerId write FServerId;
360 end;
361
362 { TFPBreakpoints }
363
364 TFPBreakpoints = class(TDBGBreakPoints)
365 public
366 function FindByUID(AnUID: integer): TFPBreakpoint;
367 function FindByServerID(AnServerID: integer): TFPBreakpoint;
368 end;
369
370 { TFPDBGDisassembler }
371
372 TFPDBGDisassembler = class(TDBGDisassembler)
373 protected
374 function PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): boolean; override;
375 public
376 // Used in the succes callback of the TFPDSendDisassembleCommand command to add
377 // the retrieved range of assembly instructions.
378 procedure AddRange(ARange: TDBGDisassemblerEntryRange);
379 end;
380
381 { TFPLocals }
382
383 TFPLocals = class(TLocalsSupplier)
384 public
385 procedure RequestData(ALocals: TLocals); override;
386 end;
387
388 { TFPRegisters }
389
390 TFPRegisters = class(TRegisterSupplier)
391 public
392 procedure RequestData(ARegisters: TRegisters); override;
393 end;
394
395 { TFPWatches }
396
397 TFPWatches = class(TWatchesSupplier)
398 protected
399 procedure InternalRequestData(AWatchValue: TWatchValue); override;
400 end;
401
402 { TFPCallStackSupplier }
403
404 TFPCallStackSupplier = class(TCallStackSupplier)
405 public
406 procedure RequestCount(ACallstack: TCallStackBase); override;
407 procedure RequestEntries(ACallstack: TCallStackBase); override;
408 procedure RequestCurrent(ACallstack: TCallStackBase); override;
409 // Used in the succes callback of the TFPDSendCallStackCommand command to trigger
410 // an update og the GUI after the callstack has been read.
411 procedure DoUpdate;
412 end;
413
414
415 procedure Register;
416 begin
417 RegisterDebugger(TFPDServerDebugger);
418 end;
419
420 { TFPDSendCommand }
421
422 var GCommandUID: integer = 0;
423
424 { TFPRegisters }
425
426 procedure TFPRegisters.RequestData(ARegisters: TRegisters);
427 begin
428 if (Debugger = nil) or not(Debugger.State = dsPause)
429 then begin
430 ARegisters.DataValidity:=ddsInvalid;
431 exit;
432 end;
433
434 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendRegistersCommand.create(ARegisters));
435 ARegisters.DataValidity := ddsRequested;
436 end;
437
438 { TFPDSendRegistersCommand }
439
440 procedure TFPDSendRegistersCommand.DoRegistersFreed(Sender: TObject);
441 begin
442 FRegisters := nil;
443 end;
444
445 procedure TFPDSendRegistersCommand.ComposeJSon(AJsonObject: TJSONObject);
446 begin
447 inherited ComposeJSon(AJsonObject);
448 AJsonObject.Add('command','registers');
449 end;
450
451 constructor TFPDSendRegistersCommand.create(ARegisters: TRegisters);
452 begin
453 inherited create(true);
454 ARegisters.AddFreeNotification(@DoRegistersFreed);
455 FRegisters := ARegisters;
456 end;
457
458 destructor TFPDSendRegistersCommand.Destroy;
459 begin
460 if assigned(FRegisters) then
461 FRegisters.RemoveFreeNotification(@DoRegistersFreed);
462 inherited Destroy;
463 end;
464
465 procedure TFPDSendRegistersCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
466 var
467 JSonRegisterArr: TJSONArray;
468 JSonRegisterEntryObj: TJSONObject;
469 i: Integer;
470 RegisterValue: TRegisterValue;
471 begin
472 inherited DoOnCommandSuccesfull(ACommandResponse);
473 if assigned(FRegisters) then
474 begin
475 FRegisters.Clear;
476
477 JSonRegisterArr := ACommandResponse.Get('registers', TJSONArray(nil));
478 if assigned(JSonRegisterArr) and (JSonRegisterArr.Count>0) then
479 begin
480 for i := 0 to JSonRegisterArr.Count - 1 do
481 begin
482 JSonRegisterEntryObj := JSonRegisterArr.Items[i] as TJSONObject;
483 RegisterValue := FRegisters.EntriesByName[JSonRegisterEntryObj.Get('name', '')];
484 RegisterValue.ValueObj.SetAsNum(JSonRegisterEntryObj.Get('numvalue', 0), JSonRegisterEntryObj.Get('size', 4));
485 RegisterValue.ValueObj.SetAsText(JSonRegisterEntryObj.Get('value', ''));
486 RegisterValue.DataValidity:=ddsValid;
487 end;
488 FRegisters.DataValidity := ddsValid;
489 end
490 else
491 FRegisters.DataValidity := ddsInvalid;
492 end;
493 end;
494
495 procedure TFPDSendRegistersCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
496 begin
497 FRegisters.DataValidity := ddsInvalid;
498 end;
499
500 { TFPDSendLocalsCommand }
501
502 procedure TFPDSendLocalsCommand.DoLocalsFreed(Sender: TObject);
503 begin
504 FLocals:=nil;
505 end;
506
507 procedure TFPDSendLocalsCommand.ComposeJSon(AJsonObject: TJSONObject);
508 begin
509 inherited ComposeJSon(AJsonObject);
510 AJsonObject.Add('command','locals');
511 end;
512
513 constructor TFPDSendLocalsCommand.create(ALocals: TLocals);
514 begin
515 inherited create(True);
516 ALocals.AddFreeNotification(@DoLocalsFreed);
517 FLocals := ALocals;
518 end;
519
520 destructor TFPDSendLocalsCommand.Destroy;
521 begin
522 if assigned(FLocals) then
523 FLocals.RemoveFreeNotification(@DoLocalsFreed);
524 inherited Destroy;
525 end;
526
527 procedure TFPDSendLocalsCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
528 var
529 JSonLocalsArr: TJSONArray;
530 JSonLocalsEntryObj: TJSONObject;
531 i: Integer;
532 begin
533 inherited DoOnCommandSuccesfull(ACommandResponse);
534 if assigned(FLocals) then
535 begin
536 FLocals.Clear;
537 JSonLocalsArr := ACommandResponse.Get('locals', TJSONArray(nil));
538 if assigned(JSonLocalsArr) and (JSonLocalsArr.Count>0) then
539 begin
540 for i := 0 to JSonLocalsArr.Count - 1 do
541 begin
542 JSonLocalsEntryObj := JSonLocalsArr.Items[i] as TJSONObject;
543 FLocals.Add(JSonLocalsEntryObj.Get('name', ''), JSonLocalsEntryObj.Get('value', ''));
544 end;
545 end;
546 FLocals.SetDataValidity(ddsValid);
547 end;
548 end;
549
550 procedure TFPDSendLocalsCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
551 begin
552 FLocals.SetDataValidity(ddsInvalid);
553 end;
554
555 procedure TFPLocals.RequestData(ALocals: TLocals);
556 begin
557 if (Debugger = nil) or not(Debugger.State = dsPause)
558 then begin
559 ALocals.SetDataValidity(ddsInvalid);
560 exit;
561 end;
562
563 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendLocalsCommand.create(ALocals));
564 ALocals.SetDataValidity(ddsRequested);
565 end;
566
567 { TFPDBGDisassembler }
568
PrepareEntriesnull569 function TFPDBGDisassembler.PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): boolean;
570 begin
571 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendDisassembleCommand.create(self, AnAddr, ALinesBefore, ALinesAfter));
572 result := false;
573 end;
574
575 procedure TFPDBGDisassembler.AddRange(ARange: TDBGDisassemblerEntryRange);
576 begin
577 EntryRanges.AddRange(ARange);
578 Changed;
579 end;
580
581 { TFPCallStackSupplier }
582
583 procedure TFPCallStackSupplier.RequestCount(ACallstack: TCallStackBase);
584 begin
585 if (Debugger = nil) or not(Debugger.State = dsPause)
586 then begin
587 ACallstack.SetCountValidity(ddsInvalid);
588 exit;
589 end;
590
591 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendCallStackCommand.create(ACallstack, Self));
592 ACallstack.SetCountValidity(ddsRequested);
593 end;
594
595 procedure TFPCallStackSupplier.RequestEntries(ACallstack: TCallStackBase);
596 begin
597 if (Debugger = nil) or not(Debugger.State = dsPause)
598 then begin
599 ACallstack.SetCountValidity(ddsInvalid);
600 exit;
601 end;
602 end;
603
604 procedure TFPCallStackSupplier.RequestCurrent(ACallstack: TCallStackBase);
605 begin
606 ACallstack.CurrentIndex := 0;
607 ACallstack.SetCurrentValidity(ddsValid);
608 end;
609
610 procedure TFPCallStackSupplier.DoUpdate;
611 begin
612 Changed;
613 end;
614
615 { TFPDSendWatchEvaluateCommand }
616
617 procedure TFPDSendWatchEvaluateCommand.DoWatchFreed(Sender: TObject);
618 begin
619 FWatchValue:=nil;
620 end;
621
622 procedure TFPDSendWatchEvaluateCommand.ComposeJSon(AJsonObject: TJSONObject);
623 begin
624 inherited ComposeJSon(AJsonObject);
625 AJsonObject.Add('command','evaluate');
626 AJsonObject.Add('expression',FWatchValue.Expression);
627 end;
628
629 constructor TFPDSendWatchEvaluateCommand.create(AWatchValue: TWatchValue);
630 begin
631 inherited create(true);
632 AWatchValue.AddFreeNotification(@DoWatchFreed);
633 FWatchValue := AWatchValue;
634 end;
635
636 destructor TFPDSendWatchEvaluateCommand.Destroy;
637 begin
638 FWatchValue.RemoveFreeNotification(@DoWatchFreed);
639 inherited Destroy;
640 end;
641
642 procedure TFPDSendWatchEvaluateCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
643 var
644 s: string;
645 i: TDebuggerDataState;
646 begin
647 inherited DoOnCommandSuccesfull(ACommandResponse);
648
649 if assigned(FWatchValue) then
650 begin
651 FWatchValue.Value:=ACommandResponse.Get('message','');
652 s := ACommandResponse.Get('validity','');
653 FWatchValue.Validity:=ddsError;
654 for i := low(TDebuggerDataState) to high(TDebuggerDataState) do
655 if DebuggerDataStateStr[i]=s then
656 begin
657 FWatchValue.Validity:=i;
658 break;
659 end;
660 end;
661 end;
662
663 procedure TFPDSendWatchEvaluateCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
664 begin
665 inherited DoOnCommandFailed(ACommandResponse);
666 FWatchValue.Validity:=ddsInvalid;
667 end;
668
669 { TFPWatches }
670
671 procedure TFPWatches.InternalRequestData(AWatchValue: TWatchValue);
672 begin
673 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendWatchEvaluateCommand.create(AWatchValue));
674 inherited InternalRequestData(AWatchValue);
675 end;
676
677 { TFPDSendEvaluateCommand }
678
679 procedure TFPDSendEvaluateCommand.ComposeJSon(AJsonObject: TJSONObject);
680 begin
681 inherited ComposeJSon(AJsonObject);
682 AJsonObject.Add('command','evaluate');
683 AJsonObject.Add('expression',FExpression);
684 end;
685
686 constructor TFPDSendEvaluateCommand.create(AnAutomaticFree: boolean; AnExpression: string);
687 begin
688 FExpression:=AnExpression;
689 FValidity:=ddsRequested;
690 inherited create(AnAutomaticFree);
691 end;
692
693 procedure TFPDSendEvaluateCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
694 var
695 s: string;
696 i: TDebuggerDataState;
697 begin
698 inherited DoOnCommandSuccesfull(ACommandResponse);
699 FMessage:=ACommandResponse.Get('message','');
700 s := ACommandResponse.Get('validity','');
701 FValidity:=ddsError;
702 for i := low(TDebuggerDataState) to high(TDebuggerDataState) do
703 if DebuggerDataStateStr[i]=s then
704 begin
705 FValidity:=i;
706 break;
707 end;
708 end;
709
710 procedure TFPDSendEvaluateCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
711 begin
712 inherited DoOnCommandFailed(ACommandResponse);
713 FValidity:=ddsInvalid;
714 end;
715
716 { TFPDSendQuitDebugServerCommand }
717
718 procedure TFPDSendQuitDebugServerCommand.ComposeJSon(AJsonObject: TJSONObject);
719 begin
720 inherited ComposeJSon(AJsonObject);
721 AJsonObject.Add('command','quitdebugserver');
722 end;
723
724 { TFPDSendRemoveBreakpointCommand }
725
726 procedure TFPDSendRemoveBreakpointCommand.ComposeJSon(AJsonObject: TJSONObject);
727 begin
728 inherited ComposeJSon(AJsonObject);
729 AJsonObject.Add('command','removebreakpoint');
730 AJsonObject.Add('BreakpointServerIdr', Dec2Numb(FId, 8, 16));
731 end;
732
733 constructor TFPDSendRemoveBreakpointCommand.create(AnId: Integer);
734 begin
735 inherited create;
736 FId:=AnId;
737 end;
738
739 { TFPDSendResetBreakpointCommand }
740
GetAsStringnull741 function TFPDSendCommand.GetAsString: string;
742 var
743 AJsonObject: TJSONObject;
744 begin
745 AJsonObject := TJSONObject.Create;
746 try
747 ComposeJSon(AJsonObject);
748 result := AJsonObject.AsJSON;
749 finally
750 AJsonObject.Free;
751 end;
752 end;
753
754 procedure TFPDSendCommand.ComposeJSon(AJsonObject: TJSONObject);
755 begin
756 AJsonObject.Add('uid', FCommandUID);
757 end;
758
759 constructor TFPDSendCommand.create(AnAutomaticFree: boolean);
760 begin
761 inc(GCommandUID);
762 FCommandUID := GCommandUID;
763 FAutomaticFree:=AnAutomaticFree;
764 end;
765
766 procedure TFPDSendCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
767 begin
768 // Do nothing
769 end;
770
771 procedure TFPDSendCommand.DoOnCommandReceived(ACommandResponse: TJSonObject);
772 begin
773 // Do nothing
774 end;
775
776 procedure TFPDSendCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
777 begin
778 // Do nothing;
779 end;
780
781 { TFPDSendCommandList }
782
SearchByUIDnull783 function TFPDSendCommandList.SearchByUID(const ACommandUID: integer): TFPDSendCommand;
784 var
785 i: Integer;
786 begin
787 for i := 0 to count -1 do
788 begin
789 if Items[i].CommandUID = ACommandUID then
790 begin
791 result := items[i];
792 exit;
793 end;
794 end;
795 result := nil;
796 end;
797
798 {$I fpdserverdebuggercommands.inc}
799
800 { TFPBreakpoint }
801
802 procedure TFPBreakpoint.SetBreak;
803 var
804 ASendCommand: TFPDSendCommand;
805 begin
806 ASendCommand := nil;
807 case Kind of
808 bpkAddress: ASendCommand := TFPDSendAddBreakpointCommand.create(Address);
809 bpkSource: ASendCommand := TFPDSendAddBreakpointCommand.create(Source, Line);
810 else
811 Raise Exception.Create('Breakpoints of this kind are not suported.');
812 end;
813 if assigned(ASendCommand) then
814 begin
815 FUID:=ASendCommand.CommandUID;
816 TFPDServerDebugger(Debugger).QueueCommand(ASendCommand);
817 end;
818 FIsSet:=true;
819 end;
820
821 procedure TFPBreakpoint.ResetBreak;
822 begin
823 if assigned(Debugger) then
824 TFPDServerDebugger(Debugger).QueueCommand(TFPDSendRemoveBreakpointCommand.create(Address));
825 FIsSet:=false;
826 end;
827
828 procedure TFPBreakpoint.DoStateChange(const AOldState: TDBGState);
829 begin
830 if (Debugger.State in [dsPause, dsInternalPause]) then
831 begin
832 if Enabled and not FIsSet then
833 begin
834 FSetBreakFlag:=true;
835 Changed;
836 end
837 else if not enabled and FIsSet then
838 begin
839 FResetBreakFlag:=true;
840 Changed;
841 end;
842 end
843 else if Debugger.State = dsStop then
844 begin
845 FIsSet:=false;
846 end;
847 inherited DoStateChange(AOldState);
848 end;
849
850 procedure TFPBreakpoint.DoEnableChange;
851 begin
852 if (Debugger.State in [dsPause, dsInit, dsRun]) then
853 begin
854 if Enabled and not FIsSet then
855 FSetBreakFlag := True
856 else if not Enabled and FIsSet then
857 FResetBreakFlag := True;
858 end;
859 inherited;
860 end;
861
862 procedure TFPBreakpoint.DoChanged;
863 begin
864 if FResetBreakFlag and not FSetBreakFlag then
865 ResetBreak
866 else if FSetBreakFlag then
867 SetBreak;
868
869 FSetBreakFlag := false;
870 FResetBreakFlag := false;
871
872 inherited DoChanged;
873 end;
874
875 procedure TFPBreakpoint.SetValid;
876 begin
877 FValid:=vsValid;
878 end;
879
880 procedure TFPBreakpoint.SetInvalid;
881 begin
882 FValid:=vsInvalid;
883 end;
884
885 destructor TFPBreakpoint.Destroy;
886 begin
887 if FIsSet then
888 ResetBreak;
889 inherited Destroy;
890 end;
891
FindByUIDnull892 function TFPBreakpoints.FindByUID(AnUID: integer): TFPBreakpoint;
893 var
894 i: integer;
895 begin
896 for i := 0 to Count-1 do
897 if TFPBreakpoint(Items[i]).UID=AnUID then
898 begin
899 result := TFPBreakpoint(Items[i]);
900 exit;
901 end;
902 result := nil;
903 end;
904
FindByServerIDnull905 function TFPBreakpoints.FindByServerID(AnServerID: integer): TFPBreakpoint;
906 var
907 i: integer;
908 begin
909 for i := 0 to Count-1 do
910 if TFPBreakpoint(Items[i]).ServerId=AnServerID then
911 begin
912 result := TFPBreakpoint(Items[i]);
913 exit;
914 end;
915 result := nil;
916 end;
917
918 { TFPDSocketThread }
919
920 procedure TFPDSocketThread.ReceivedCommand(Data: PtrInt);
921 var
922 ACommand: TJSONObject;
923 begin
924 ACommand := TObject(data) as TJSONObject;
925 FDebugger.ReceivedCommand(ACommand);
926 ACommand.Free;
927 end;
928
929 procedure TFPDSocketThread.ConnectionProblem(Data: PtrInt);
930 begin
931 FDebugger.DoOnConnectionProblem(FErrMessage);
932 end;
933
934 procedure TFPDSocketThread.Execute;
935 const
936 InputBufferSize = 1024;
937 var
938 SendStr: string;
939 s: string;
940 i: integer;
941 InputStr: string;
942 JSonData: TJSONData;
943 ASocket: TInetSocket;
944
945 function ReadString: string;
946 var
947 InputBuffer: array[0..InputBufferSize-1] of char;
948 s: string;
949 begin
950 // First see if there is a string left in the input-buffer.
951 i := pos(#10, InputStr);
952 if i > 0 then
953 begin
954 s := copy(InputStr, 1, i-1);
955 delete(InputStr,1,i);
956 result := s;
957 exit;
958 end;
959
960 result := '';
961 i := ASocket.Read(InputBuffer[0], InputBufferSize-1);
962 if i=0 then
963 begin
964 // Connection closed
965 FErrMessage := 'Connection with FPDebug-server closed.';
966 Terminate;
967 end
968 else if i<0 then
969 begin
970 if ASocket.LastError<>35 {EAGAIN} then
971 begin
972 FErrMessage := 'Error during write to FPDebug-server. Socket-error: '+inttostr(ASocket.LastError);
973 Terminate;
974 end;
975 end
976 else if i > 0 then
977 begin
978 setlength(s,i);
979 move(InputBuffer[0],s[1],i);
980 InputStr:=InputStr+s;
981 i := pos(#10, InputStr);
982 if i > 0 then
983 begin
984 s := copy(InputStr, 1, i-1);
985 delete(InputStr,1,i);
986 result := s;
987 end;
988 end;
989 end;
990
991 function ReadSTringTimeout(ATimeout: integer): string;
992 var
993 tc: int64;
994 begin
995 tc := GetTickCount64;
996 result := ReadString;
997 while not terminated and (result='') and ((GetTickCount64-tc)<ATimeout) do
998 begin
999 sleep(1);
1000 result := ReadString;
1001 end;
1002 end;
1003
1004 var
1005 IsConnected: boolean;
1006 begin
1007 IsConnected:=false;
1008 FErrMessage:='';
1009 try
1010 ASocket := TInetSocket.Create(FHostName, FPort);
1011 try
1012 if not assigned(ASocket) then
1013 begin
1014 FErrMessage:='Failed to connect to fpdebug-server at '+FHostName+':'+IntToStr(FPort);
1015 Terminate;
1016 end
1017 else
1018 begin
1019 // Set non-blocking
1020 {$IFDEF UNIX}
1021 fpfcntl(ASocket.Handle,F_SETFL,O_NONBLOCK);
1022 {$ENDIF}
1023
1024 // Read and check FPDebug Server greeting
1025 s := ReadSTringTimeout(100);
1026 if s='Welcome to FPDebug-server.' then
1027 begin
1028 // Read connection-identifier
1029 s := ReadSTringTimeout(100);
1030 delete(s,length(s),1);
1031 s := copy(s, rpos(' ',s)+1, 5);
1032 FConnectionIdentifier:=StrToIntDef(s,-1);
1033 if FConnectionIdentifier>-1 then
1034 begin
1035 // Skip help-message
1036 s := ReadSTringTimeout(100);
1037 IsConnected:=True;
1038 end;
1039 end;
1040
1041 if not IsConnected then
1042 begin
1043 FErrMessage:='Connected to '+FHostName+':'+inttostr(FPort)+', but failed to negotiate handshake.';
1044 Terminate;
1045 end;
1046 end;
1047
1048 while not terminated do
1049 begin
1050 repeat
1051 s:=ReadString;
1052 if s<>'' then
1053 begin
1054 JSonData := GetJSON(s);
1055 if JSonData is TJSONObject then
1056 Application.QueueAsyncCall(@ReceivedCommand, ptrint(JSonData))
1057 else
1058 raise exception.CreateFmt('JSon-command %s is not a JSON-Object.',[s]);
1059 end;
1060 // When one string has been received, there is a large chance that there is more
1061 // input waiting. Keep checking for input until the input-buffer is empty, before
1062 // the thread starts waiting for new commands using FSendQueue.PopItem.
1063 until s='';
1064
1065 if not terminated and (FSendQueue.PopItem(SendStr) = wrSignaled) then
1066 begin
1067 SendStr := SendStr + #10;
1068 i := ASocket.Write(SendStr[1], length(SendStr));
1069
1070 if i < 0 then
1071 begin
1072 if ASocket.LastError=32 then
1073 begin
1074 // Lost connection
1075 end
1076 else
1077 DebugLn(Format('Error during write. Socket-error: %d',[ASocket.LastError]));
1078 Terminate;
1079 end
1080 else if i < length(SendStr) then
1081 raise exception.create('Message has not been send to client entirely');
1082 end;
1083 end;
1084 finally
1085 ASocket.Free;
1086 end;
1087 except
1088 on E: Exception do
1089 begin
1090 FErrMessage:='Exception on connection with FPDebug-server: ' + E.Message;
1091 end;
1092 end;
1093
1094 // There are two different ways in which the thread can terminate:
1095 // 1: The thread terminates itself, due to a lost connection or similar problem. In that case the
1096 // thread is freed in the TFPDServerDebugger.DoConnectionProblem method.
1097 // 2: TFPDServerDebugger.Destroy terminates the thread. In that case it will also free the thread, and
1098 // the asynchrounous call to ConnectionProblem is removed from the async-queue.
1099 Application.QueueAsyncCall(@ConnectionProblem, 0);
1100 end;
1101
1102 constructor TFPDSocketThread.Create(ADebugger: TFPDServerDebugger;
1103 AHostName: string; APort: integer);
1104 begin
1105 FHostName:=AHostName;
1106 FPort:=APort;
1107 FDebugger := ADebugger;
1108 FSendQueue:=TThreadedQueueString.create(100, INFINITE, 100);
1109 inherited create(false);
1110 end;
1111
1112 procedure TFPDSocketThread.SendString(AString: string);
1113 begin
1114 if Assigned(FDebugger.OnDbgOutput) then
1115 FDebugger.OnDbgOutput(Self, 'send: '+AString);
1116 FSendQueue.PushItem(AString);
1117 end;
1118
1119 destructor TFPDSocketThread.Destroy;
1120 begin
1121 FSendQueue.Free;
1122 Application.RemoveAsyncCalls(Self);
1123 inherited destroy;
1124 end;
1125
1126 { TFPDServerDebugger }
1127
ConnectToFPDServernull1128 function TFPDServerDebugger.ConnectToFPDServer: boolean;
1129 var
1130 buff,s: string;
1131 dw: dword;
1132 tc: Int64;
1133 js: TJSONData;
1134 port: integer;
1135 begin
1136 if not FIsConnected then
1137 begin
1138 result := false;
1139 port := -1;
1140 if PosI('gdb', ExtractFileName(ExternalDebugger)) > 0 then
1141 ShowMessage('The name of the external debugger contains ''gdb''. The currently selected FPDebug-debugger can not work in combination with gdb. The debugger will most likely fail to start.');
1142 FDebugProcess := TProcessUTF8.Create(nil);
1143 try
1144 try
1145 FDebugProcess.Executable:=ExternalDebugger;
1146 FDebugProcess.Options:=[poUsePipes, poNoConsole, poNewProcessGroup];
1147 FDebugProcess.Parameters.Add('--tcp');
1148 FDebugProcess.Parameters.Add('--daemon');
1149 FDebugProcess.Parameters.Add('--autoport');
1150 FDebugProcess.Parameters.Add('--interactive');
1151 FDebugProcess.ShowWindow:=swoNone;
1152
1153 DoDbgOutput('Start debugger: '+FDebugProcess.Executable + ' ' + StringReplace(FDebugProcess.Parameters.Text,LineEnding,' ',[rfReplaceAll]));
1154
1155 FDebugProcess.Execute;
1156 // Wait and scan output for tcp/ip port number
1157 s := '';
1158 buff := '';
1159 dw := 0;
1160 tc := GetTickCount64;
1161 while FDebugProcess.Running and ((GetTickCount64-tc)<5000) and (dw<1) do
1162 begin
1163 dw := FDebugProcess.Output.NumBytesAvailable;
1164 if dw > 0 then
1165 begin
1166 setlength(buff, dw);
1167 FDebugProcess.Output.ReadBuffer(buff[1], dw);
1168 s := s + buff;
1169 dw := pos(#10,s);
1170 end;
1171 sleep(5);
1172 end;
1173 if dw>0 then
1174 begin
1175 s := copy(s,1,dw);
1176
1177 DoDbgOutput('recv stdin: '+S);
1178
1179 js := GetJSON(s);
1180 try
1181 if js.JSONType=jtObject then
1182 port := TJSONObject(js).Get('port',-1);
1183 finally
1184 js.Free;
1185 end;
1186 if port<1 then
1187 ShowMessage('No valid TCP/IP port to bind to FPDebug Server');
1188 end
1189 else
1190 ShowMessage('Invalid response from FPDebug Server');
1191 except
1192 on E: Exception do
1193 ShowMessage('Failed to run FPDebug Server: '+E.Message);
1194 end;
1195 finally
1196 if port<1 then
1197 FDebugProcess.Free;
1198 end;
1199
1200 if port>-1 then
1201 begin
1202 FSocketThread := TFPDSocketThread.Create(Self, '127.0.0.1', port);
1203 FDebugServerStartedAsChild:=true;
1204 FIsConnected:=true;
1205 result := true;
1206 end;
1207 end
1208 else
1209 result := true;
1210 end;
1211
1212 procedure TFPDServerDebugger.DisconnectFromFPDServer;
1213 begin
1214 if FDebugServerStartedAsChild then
1215 begin
1216 // Try to send the FPDebug server the command to terminate. It could be that
1217 // the server is already gone, but try anyway and give it some time to terminate
1218 // by itself.
1219 QueueCommand(TFPDSendQuitDebugServerCommand.create);
1220 WaitForThreadTerminate(FSocketThread.Handle, 1000);
1221 end;
1222
1223 FSocketThread.Terminate;
1224 FSocketThread.WaitFor;
1225 FSocketThread.Free;
1226
1227 if FDebugServerStartedAsChild then
1228 begin
1229 if FDebugProcess.Running then
1230 FDebugProcess.Terminate(1);
1231 FDebugProcess.Free;
1232 end;
1233 end;
1234
1235 class function TFPDServerDebugger.GetSupportedCommands: TDBGCommands;
1236 begin
1237 Result:=[dcRun, dcStepOver, dcStepInto, dcStepOut, dcStepOverInstr, dcStepIntoInstr, dcStop, dcEvaluate];
1238 end;
1239
1240 procedure TFPDServerDebugger.DoHandleCreateProcessEvent(AnEvent: TJSONObject);
1241 begin
1242 SetState(dsInternalPause);
1243 QueueCommand(TFPDSendContinueCommand.create);
1244 end;
1245
1246 procedure TFPDServerDebugger.DoHandleExitProcessEvent(AnEvent: TJSONObject);
1247 begin
1248 SetState(dsStop);
1249 end;
1250
1251 procedure TFPDServerDebugger.DoHandleBreakpointEvent(AnEvent: TJSONObject);
1252 var
1253 BrkId: Integer;
1254 Brk: TDBGBreakPoint;
1255 Continue: boolean;
1256 begin
1257 BrkId:=AnEvent.Get('BreakpointServerIdr',0);
1258 if BrkId<>0 then
1259 begin
1260 Brk := TFPBreakPoints(BreakPoints).FindByServerID(BrkId);
1261 if not assigned(brk) then
1262 debugln('Break on unknown breakpoint')
1263 else
1264 begin
1265 brk.Hit(Continue);
1266 if Continue then
1267 begin
1268 QueueCommand(TFPDSendContinueCommand.create);
1269 Exit;
1270 end;
1271 end;
1272 end;
1273
1274 SetState(dsPause);
1275 QueueCommand(TFPDSendDoCurrentCommand.create);
1276 end;
1277
1278 procedure TFPDServerDebugger.DoHandleConsoleOutputEvent(AnEvent: TJSONObject);
1279 var
1280 AMessage: string;
1281 begin
1282 AMessage:=AnEvent.Get('message','');
1283 OnConsoleOutput(Self, AMessage);
1284 end;
1285
1286 procedure TFPDServerDebugger.HandleNotification(ANotification: TJSONObject);
1287 var
1288 NotificationType: string;
1289 UID: integer;
1290 SendCommand: TFPDSendCommand;
1291 begin
1292 // Ignore notifications from other connections
1293 if ANotification.get('connIdentifier',-1)=FSocketThread.ConnectionIdentifier then
1294 begin
1295 NotificationType:=ANotification.Get('notificationType','');
1296 case NotificationType of
1297 'InvalidCommand':
1298 raise exception.CreateFmt('The FPD-Server complains about an invalid command: %s',[ANotification.get('message', '-')]);
1299 'ExecutedCommand', 'FailedCommand', 'ReceivedCommand':
1300 begin
1301 uid := ANotification.get('uid',-1);
1302 if uid > -1 then
1303 begin
1304 SendCommand := FCommandList.SearchByUID(uid);
1305 if assigned(SendCommand) then
1306 begin
1307 case NotificationType of
1308 'ExecutedCommand':
1309 begin
1310 SendCommand.DoOnCommandSuccesfull(ANotification);
1311 if SendCommand.AutomaticFree then
1312 FCommandList.Remove(SendCommand)
1313 else
1314 FCommandList.Extract(SendCommand);
1315 end;
1316 'FailedCommand' :
1317 begin
1318 SendCommand.DoOnCommandFailed(ANotification);
1319 if SendCommand.AutomaticFree then
1320 FCommandList.Remove(SendCommand)
1321 else
1322 FCommandList.Extract(SendCommand);
1323 end;
1324 'ReceivedCommand':
1325 SendCommand.DoOnCommandReceived(ANotification);
1326 end; {case}
1327 end
1328 else
1329 debugln('Received command-notification for unknown command-uid '+inttostr(UID));
1330 end
1331 else
1332 debugln('Received command notification without UID');
1333 end;
1334 end; {case}
1335 end;
1336 end;
1337
1338 procedure TFPDServerDebugger.HandleLog(ALog: TJSONObject);
1339 var
1340 LogType: string;
1341 Message: string;
1342 begin
1343 LogType:=ALog.get('logType','');
1344 Message:=ALog.Get('message','');
1345 case LogType of
1346 'debug' : DebugLn(Message);
1347 'info' : ShowMessage(Message);
1348 'error' : raise Exception.Create(Message);
1349 else
1350 raise Exception.CreateFmt('Received unknown log-type from FPDebug-server. (%s)', [LogType]);
1351 end; {case}
1352 end;
1353
1354 procedure TFPDServerDebugger.HandleEvent(ANotification: TJSONObject);
1355 var
1356 EventName: string;
1357 begin
1358 EventName:=ANotification.get('eventName','');
1359 case EventName of
1360 'CreateProcess' : DoHandleCreateProcessEvent(ANotification);
1361 'ExitProcess' : DoHandleExitProcessEvent(ANotification);
1362 'BreakPoint' : DoHandleBreakPointEvent(ANotification);
1363 'ConsoleOutput' : DoHandleConsoleOutputEvent(ANotification);
1364 else
1365 debugln('Received unknown event: '+EventName);
1366 end;
1367 end;
1368
1369 procedure TFPDServerDebugger.QueueCommand(ACommand: TFPDSendCommand);
1370 begin
1371 ACommand.FServerDebugger := self;
1372 FCommandList.Add(ACommand);
1373 FSocketThread.SendString(ACommand.AsString);
1374 end;
1375
1376 constructor TFPDServerDebugger.Create(const AExternalDebugger: String);
1377 begin
1378 inherited Create(AExternalDebugger);
1379 FCommandList := TFPDSendCommandList.Create(true);
1380 end;
1381
1382 destructor TFPDServerDebugger.Destroy;
1383 begin
1384 if FIsConnected then
1385 DisconnectFromFPDServer;
1386 FCommandList.Free;
1387 inherited Destroy;
1388 end;
1389
1390 procedure TFPDServerDebugger.ReceivedCommand(ACommand: TJSONObject);
1391 var
1392 TypeStr: string;
1393 begin
1394 DoDbgOutput('recv: '+ACommand.AsJSON);
1395
1396 TypeStr := ACommand.Get('type','');
1397 case TypeStr of
1398 'event' : HandleEvent(ACommand);
1399 'log' : HandleLog(ACommand);
1400 'notification' : HandleNotification(ACommand);
1401 else
1402 raise Exception.CreateFmt('Received unknown event-type. (%s)',[TypeStr]);
1403 end;
1404 end;
1405
1406 class function TFPDServerDebugger.Caption: String;
1407 begin
1408 Result:='FpDebug external Dwarf-debugger (fpdserver, alpha)';
1409 end;
1410
CreateBreakPointsnull1411 function TFPDServerDebugger.CreateBreakPoints: TDBGBreakPoints;
1412 begin
1413 Result := TFPBreakPoints.Create(Self, TFPBreakpoint);
1414 end;
1415
CreateWatchesnull1416 function TFPDServerDebugger.CreateWatches: TWatchesSupplier;
1417 begin
1418 Result := TFPWatches.Create(Self);
1419 end;
1420
CreateLocalsnull1421 function TFPDServerDebugger.CreateLocals: TLocalsSupplier;
1422 begin
1423 Result := TFPLocals.Create(Self);
1424 end;
1425
CreateRegistersnull1426 function TFPDServerDebugger.CreateRegisters: TRegisterSupplier;
1427 begin
1428 Result:=TFPRegisters.Create(Self);
1429 end;
1430
CreateCallStacknull1431 function TFPDServerDebugger.CreateCallStack: TCallStackSupplier;
1432 begin
1433 Result:=TFPCallStackSupplier.Create(Self);
1434 end;
1435
CreateDisassemblernull1436 function TFPDServerDebugger.CreateDisassembler: TDBGDisassembler;
1437 begin
1438 Result:=TFPDBGDisassembler.Create(Self);
1439 end;
1440
RequestCommandnull1441 function TFPDServerDebugger.RequestCommand(const ACommand: TDBGCommand;
1442 const AParams: array of const; const ACallback: TMethod): Boolean;
1443 var
1444 ASendCommand: TFPDSendEvaluateCommand;
1445 tc: qword;
1446 begin
1447 result := true;
1448 case ACommand of
1449 dcRun:
1450 begin
1451 if State in [dsPause, dsInternalPause] then
1452 begin
1453 QueueCommand(TFPDSendContinueCommand.create);
1454 end
1455 else
1456 begin
1457 result := ConnectToFPDServer;
1458 if result then
1459 begin
1460 QueueCommand(TFPDSendFilenameCommand.create(FileName));
1461 QueueCommand(TFPDSendRunCommand.create);
1462 SetState(dsInit);
1463 end
1464 else
1465 SetState(dsStop);
1466 end;
1467 end;
1468 dcStepOver:
1469 begin
1470 QueueCommand(TFPDSendNextCommand.create);
1471 SetState(dsRun);
1472 end;
1473 dcStepInto:
1474 begin
1475 QueueCommand(TFPDSendStepCommand.create);
1476 SetState(dsRun);
1477 end;
1478 dcStepIntoInstr:
1479 begin
1480 QueueCommand(TFPDSendStepIntoInstrCommand.create);
1481 SetState(dsRun);
1482 end;
1483 dcStepOverInstr:
1484 begin
1485 QueueCommand(TFPDSendStepOverInstrCommand.create);
1486 SetState(dsRun);
1487 end;
1488 dcStepOut:
1489 begin
1490 QueueCommand(TFPDSendStepOutCommand.create);
1491 SetState(dsRun);
1492 end;
1493 dcStop:
1494 begin
1495 QueueCommand(TFPDSendStopCommand.create);
1496 if state=dsPause then
1497 SetState(dsRun);
1498 end;
1499 dcEvaluate:
1500 begin
1501 ASendCommand := TFPDSendEvaluateCommand.create(False, String(AParams[0].VAnsiString));
1502 QueueCommand(ASendCommand);
1503 tc := GetTickCount64;
1504 repeat
1505 sleep(5);
1506 Application.ProcessMessages;
1507 until (ASendCommand.Validity<>ddsRequested) or ((GetTickCount64-tc)>2000);
1508 TDBGEvaluateResultCallback(ACallback)(Self, True, ASendCommand.Message, nil);
1509 Result := True;
1510 ASendCommand.Free;
1511 end
1512 else
1513 result := false;
1514 end;
1515 end;
1516
1517 procedure TFPDServerDebugger.DoOnRunFailed;
1518 begin
1519 // TDebuggerIntf.SetFileName has set the state to dsStop, to make sure
1520 // that dcRun could be requested. Reset the filename so that the state
1521 // is set to dsIdle again and is set to dsStop on the next try
1522 // to run.
1523 FileName := ''
1524 end;
1525
1526 procedure TFPDServerDebugger.DoOnContinueSuccessfull;
1527 begin
1528 SetState(dsRun);
1529 end;
1530
1531 procedure TFPDServerDebugger.DoOnDoCurrentSuccessfull(ALocRec: TDBGLocationRec);
1532 begin
1533 DoCurrent(ALocRec);
1534 end;
1535
1536 procedure TFPDServerDebugger.DoOnConnectionProblem(AMessage: string);
1537 begin
1538 if AMessage<>'' then
1539 ShowMessage(AMessage);
1540 FIsConnected:=false;
1541 DisconnectFromFPDServer;
1542 SetState(dsStop);
1543 end;
1544
1545 end.
1546
1547