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