1 unit FPDbgController;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes,
9   SysUtils,
10   Maps,
11   LazLogger,
12   DbgIntfBaseTypes,
13   FpDbgDisasX86,
14   FpDbgClasses;
15 
16 type
17 
18   TOnCreateProcessEvent = procedure(var continue: boolean) of object;
19   TOnHitBreakpointEvent = procedure(var continue: boolean; const Breakpoint: TFpInternalBreakpoint) of object;
20   TOnExceptionEvent = procedure(var continue: boolean; const ExceptionClass, ExceptionMessage: string) of object;
21   TOnProcessExitEvent = procedure(ExitCode: DWord) of object;
22 
23   TDbgController = class;
24 
25   { TDbgControllerCmd }
26 
27   TDbgControllerCmd = class
28   protected
29     FController: TDbgController;
30   public
31     constructor Create(AController: TDbgController); virtual;
32     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); virtual; abstract;
33     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); virtual; abstract;
34   end;
35 
36   { TDbgControllerContinueCmd }
37 
38   TDbgControllerContinueCmd = class(TDbgControllerCmd)
39   public
40     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
41     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
42   end;
43 
44   { TDbgControllerStepIntoInstructionCmd }
45 
46   TDbgControllerStepIntoInstructionCmd = class(TDbgControllerCmd)
47   public
48     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
49     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
50   end;
51 
52   { TDbgControllerStepOverInstructionCmd }
53 
54   TDbgControllerStepOverInstructionCmd = class(TDbgControllerCmd)
55   private
56     FHiddenBreakpoint: TFpInternalBreakpoint;
57     FIsSet: boolean;
58   public
59     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
60     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
61   end;
62 
63   { TDbgControllerStepOutInstructionCmd }
64 
65   TDbgControllerStepOutInstructionCmd = class(TDbgControllerCmd)
66   private
67     FHiddenBreakpoint: TFpInternalBreakpoint;
68     FIsSet: boolean;
69     FProcess: TDbgProcess;
70     FThread: TDbgThread;
71     FStepCount: Integer;
72     FStepOut: Boolean;
73   protected
74     procedure SetReturnAdressBreakpoint(AProcess: TDbgProcess);
75   public
76     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
77     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
78   end;
79 
80   { TDbgControllerStepOverLineCmd }
81 
82   TDbgControllerStepOverLineCmd = class(TDbgControllerStepOverInstructionCmd)
83   private
84     FInfoStored: boolean;
85     FStoredStackFrame: TDBGPtr;
86   public
87     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
88     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
89   end;
90 
91   { TDbgControllerStepIntoLineCmd }
92 
93   TDbgControllerStepIntoLineCmd = class(TDbgControllerCmd)
94   private
95     FInfoStored: boolean;
96     FStoredStackFrame: TDBGPtr;
97     FInto: boolean;
98     FHiddenWatchpointInto: integer;
99     FHiddenWatchpointOut: integer;
100     FHiddenWatchpointOutStackbase: integer;
101     FLastStackPointerValue: TDBGPtr;
102     FLastStackBaseValue: TDBGPtr;
103     FAssumedProcStartStackPointer: TDBGPtr;
104     FHiddenBreakpoint: TFpInternalBreakpoint;
105     FInstCount: integer;
106   public
107     constructor Create(AController: TDbgController); override;
108     destructor Destroy; override;
109     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
110     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
111   end;
112 
113   { TDbgControllerRunToCmd }
114 
115   TDbgControllerRunToCmd = class(TDbgControllerCmd)
116   private
117     FHiddenBreakpoint: TFpInternalBreakpoint;
118     FLocation: TDBGPtrArray;
119     FProcess: TDbgProcess;
120   public
121     constructor Create(AController: TDbgController; ALocation: TDBGPtrArray);
122     procedure DoContinue(AProcess: TDbgProcess; AThread: TDbgThread); override;
123     procedure ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean); override;
124   end;
125 
126   { TDbgController }
127 
128   TDbgController = class
129   private
130     FEnvironment: TStrings;
131     FExecutableFilename: string;
132     FNextOnlyStopOnStartLine: boolean;
133     FOnCreateProcessEvent: TOnCreateProcessEvent;
134     FOnDebugInfoLoaded: TNotifyEvent;
135     FOnExceptionEvent: TOnExceptionEvent;
136     FOnHitBreakpointEvent: TOnHitBreakpointEvent;
137     FOnLog: TOnLog;
138     FOnProcessExitEvent: TOnProcessExitEvent;
139     FProcessMap: TMap;
140     FPDEvent: TFPDEvent;
141     FParams: TStringList;
142     FConsoleTty: string;
143     FRedirectConsoleOutput: boolean;
144     FWorkingDirectory: string;
145     procedure SetEnvironment(AValue: TStrings);
146     procedure SetExecutableFilename(AValue: string);
147     procedure SetOnLog(AValue: TOnLog);
148     procedure DoOnDebugInfoLoaded(Sender: TObject);
149     procedure SetParams(AValue: TStringList);
150   protected
151     FMainProcess: TDbgProcess;
152     FCurrentProcess: TDbgProcess;
153     FCurrentThread: TDbgThread;
154     FCommand: TDbgControllerCmd;
155     procedure Log(const AString: string; const ALogLevel: TFPDLogLevel = dllDebug);
156     procedure Log(const AString: string; const Options: array of const; const ALogLevel: TFPDLogLevel = dllDebug);
GetProcessnull157     function GetProcess(const AProcessIdentifier: THandle; out AProcess: TDbgProcess): Boolean;
158   public
159     constructor Create; virtual;
160     destructor Destroy; override;
161     procedure InitializeCommand(ACommand: TDbgControllerCmd);
Runnull162     function Run: boolean;
163     procedure Stop;
164     procedure StepIntoInstr;
165     procedure StepOverInstr;
166     procedure Next;
167     procedure Step;
168     procedure StepOut;
Pausenull169     function Pause: boolean;
170     procedure ProcessLoop;
171     procedure SendEvents(out continue: boolean);
172 
173     property ExecutableFilename: string read FExecutableFilename write SetExecutableFilename;
174     property OnLog: TOnLog read FOnLog write SetOnLog;
175     property CurrentProcess: TDbgProcess read FCurrentProcess;
176     property CurrentThread: TDbgThread read FCurrentThread;
177     property MainProcess: TDbgProcess read FMainProcess;
178     property Params: TStringList read FParams write SetParams;
179     property Environment: TStrings read FEnvironment write SetEnvironment;
180     property WorkingDirectory: string read FWorkingDirectory write FWorkingDirectory;
181     property RedirectConsoleOutput: boolean read FRedirectConsoleOutput write FRedirectConsoleOutput;
182     property ConsoleTty: string read FConsoleTty write FConsoleTty;
183     // With this parameter set a 'next' will only stop if the current
184     // instruction is the first instruction of a line according to the
185     // debuginfo.
186     // Due to a bug in fpc's debug-info, the line info for the first instruction
187     // of a line, sometimes points the the prior line. This setting hides the
188     // results of that bug. It seems like it that GDB does something similar.
189     property NextOnlyStopOnStartLine: boolean read FNextOnlyStopOnStartLine write FNextOnlyStopOnStartLine;
190 
191     property OnCreateProcessEvent: TOnCreateProcessEvent read FOnCreateProcessEvent write FOnCreateProcessEvent;
192     property OnHitBreakpointEvent: TOnHitBreakpointEvent read FOnHitBreakpointEvent write FOnHitBreakpointEvent;
193     property OnProcessExitEvent: TOnProcessExitEvent read FOnProcessExitEvent write FOnProcessExitEvent;
194     property OnExceptionEvent: TOnExceptionEvent read FOnExceptionEvent write FOnExceptionEvent;
195     property OnDebugInfoLoaded: TNotifyEvent read FOnDebugInfoLoaded write FOnDebugInfoLoaded;
196   end;
197 
198 implementation
199 
200 { TDbgControllerStepOutInstructionCmd }
201 
202 procedure TDbgControllerStepOutInstructionCmd.SetReturnAdressBreakpoint(AProcess: TDbgProcess);
203 var
204   AStackPointerValue, StepOutStackPos, ReturnAddress: TDBGPtr;
205 begin
206   AStackPointerValue:=FController.CurrentThread.GetStackBasePointerRegisterValue;
207   StepOutStackPos:=AStackPointerValue+DBGPTRSIZE[FController.FCurrentProcess.Mode];
208 
209   if AProcess.ReadAddress(StepOutStackPos, ReturnAddress) then
210   begin
211     FProcess := AProcess;
212     if not AProcess.HasBreak(ReturnAddress) then
213       FHiddenBreakpoint := AProcess.AddBreak(ReturnAddress)
214   end
215   else
216   begin
217     AProcess.Log('Failed to read return-address from stack');
218   end;
219 
220   FIsSet:=true;
221 end;
222 
223 procedure TDbgControllerStepOutInstructionCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
224 var
225   CodeBin: array[0..20] of byte;
226   p: pointer;
227   ADump,
228   AStatement: string;
229 begin
230   FThread := AThread;
231   FProcess := AProcess;
232   if FIsSet then
233     // When a breanpoint has already been set on the return-adress, just continue
234     AProcess.Continue(AProcess, AThread, false)
235   else if FStepCount < 12 then
236   begin
237     // During the prologue and epiloge of a procedure the call-stack might not been
238     // setup already. To avoid problems in these cases, start with a few (max
239     // 12) single steps.
240     Inc(FStepCount);
241     if AProcess.ReadData(AThread.GetInstructionPointerRegisterValue,sizeof(CodeBin),CodeBin) then
242     begin
243       p := @CodeBin;
244       Disassemble(p, AProcess.Mode=dm64, ADump, AStatement);
245       if (copy(AStatement,1,4)='call') then
246       begin
247         // Stop with the single-steps, set an hidden breakpoint at the return
248         // address and continue.
249         SetReturnAdressBreakpoint(AProcess);
250         AProcess.Continue(AProcess, AThread, False);
251       end
252       else if (copy(AStatement,1,3)='ret') then
253       begin
254         // Do one more single-step, and we're finished.
255         FStepOut := True;
256         AProcess.Continue(AProcess, AThread, True);
257       end
258       else
259         AProcess.Continue(AProcess, AThread, True);
260     end
261     else
262       AProcess.Continue(AProcess, AThread, True);
263   end
264   else
265   begin
266     // Enough with the single-stepping, set an hidden breakpoint at the return
267     // address, and continue.
268     SetReturnAdressBreakpoint(AProcess);
269     AProcess.Continue(AProcess, AThread, False);
270   end;
271 end;
272 
273 procedure TDbgControllerStepOutInstructionCmd.ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean);
274 begin
275   Handled := false;
276   Finished := false;
277 
278   if FStepOut then
279     // During single-stepping a 'ret' instruction was encountered. So we're just
280     // finished.
281     Finished := true
282   else if FIsSet then
283     Finished := not (AnEvent in [deInternalContinue, deLoadLibrary])
284   else if (AnEvent in [deBreakpoint]) and not FProcess.HasBreak(FThread.GetInstructionPointerRegisterValue) then
285     // Single-stepping, so continue silently.
286     AnEvent := deInternalContinue;
287 
288   if Finished and Assigned(FHiddenBreakpoint) then
289   begin
290     FProcess.RemoveBreak(FHiddenBreakpoint);
291     FHiddenBreakpoint.Free;
292   end;
293 end;
294 
295 { TDbgControllerRunToCmd }
296 
297 constructor TDbgControllerRunToCmd.Create(AController: TDbgController; ALocation: TDBGPtrArray);
298 begin
299   inherited create(AController);
300   FLocation:=ALocation;
301 end;
302 
303 procedure TDbgControllerRunToCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
304 begin
305   FProcess := AProcess;
306   if not assigned(FHiddenBreakpoint) then // and not AProcess.HasBreak(FLocation)
307     FHiddenBreakpoint := AProcess.AddBreak(FLocation)
308   else
309     FProcess.Log('TDbgControllerRunToCmd.DoContinue: Breakpoint already used');
310 
311   AProcess.Continue(AProcess, AThread, False);
312 end;
313 
314 procedure TDbgControllerRunToCmd.ResolveEvent(var AnEvent: TFPDEvent; out
315   Handled, Finished: boolean);
316 begin
317   Handled := false;
318   Finished := (AnEvent<>deInternalContinue);
319   if Finished and assigned(FHiddenBreakpoint) then
320     begin
321     FProcess.RemoveBreak(FHiddenBreakpoint);
322     FHiddenBreakpoint.Free;
323     end;
324 end;
325 
326 { TDbgControllerStepIntoLineCmd }
327 
328 constructor TDbgControllerStepIntoLineCmd.Create(AController: TDbgController);
329 begin
330   inherited Create(AController);
331   FHiddenWatchpointInto:=-1;
332   FHiddenWatchpointOut:=-1;
333   FHiddenWatchpointOutStackbase:=-1;
334 end;
335 
336 destructor TDbgControllerStepIntoLineCmd.Destroy;
337 begin
338   if assigned(FHiddenBreakpoint) then
339     begin
340     FController.CurrentProcess.RemoveBreak(FHiddenBreakpoint);
341     FreeAndNil(FHiddenBreakpoint);
342     end;
343   inherited Destroy;
344 end;
345 
346 procedure TDbgControllerStepIntoLineCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
347 
348 var
349   CodeBin: array[0..20] of byte;
350   p: pointer;
351   ADump,
352   AStatement: string;
353   ALocation: TDBGPtr;
354 
355 begin
356   if not FInfoStored then
357   begin
358     FInfoStored:=true;
359     FStoredStackFrame:=AThread.GetStackBasePointerRegisterValue;
360     AThread.StoreStepInfo;
361   end;
362 
363   if not FInto then
364   begin
365     if AProcess.ReadData(AThread.GetInstructionPointerRegisterValue,sizeof(CodeBin),CodeBin) then
366     begin
367       p := @CodeBin;
368       Disassemble(p, AProcess.Mode=dm64, ADump, AStatement);
369       if (copy(AStatement,1,4)='call') then
370         begin
371         FInto := true;
372         FInstCount := 0;
373 
374         ALocation := AThread.GetInstructionPointerRegisterValue+(PtrUInt(p)-PtrUInt(@codebin));
375         if not AProcess.HasBreak(ALocation) then
376           FHiddenBreakpoint := AProcess.AddBreak(ALocation);
377 
378         AProcess.Continue(AProcess, AThread, true);
379         exit;
380         end;
381     end;
382   end;
383 
384   AProcess.Continue(AProcess, AThread, (FHiddenWatchpointInto=-1) and (FHiddenWatchpointOut=-1));
385 end;
386 
387 procedure TDbgControllerStepIntoLineCmd.ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean);
388 
389 var
390   AStackPointerValue: TDBGPtr;
391   AStackBasePointerValue: TDBGPtr;
392 
393   procedure SetHWBreakpoints;
394   var
395     OutStackPos: TDBGPtr;
396     StackBasePos: TDBGPtr;
397     IntoStackPos: TDBGPtr;
398   begin
399     IntoStackPos:=AStackPointerValue-DBGPTRSIZE[FController.FCurrentProcess.Mode];
400     OutStackPos:=FAssumedProcStartStackPointer;
401     StackBasePos:=AStackBasePointerValue;
402 
403     FHiddenWatchpointInto := FController.FCurrentThread.AddWatchpoint(IntoStackPos);
404     FHiddenWatchpointOut := FController.FCurrentThread.AddWatchpoint(OutStackPos);
405     FHiddenWatchpointOutStackbase := FController.FCurrentThread.AddWatchpoint(StackBasePos);
406   end;
407 
408 begin
409   if (FHiddenWatchpointOut<>-1) and FController.FCurrentThread.RemoveWatchpoint(FHiddenWatchpointOut) then
410     FHiddenWatchpointOut:=-1;
411   if (FHiddenWatchpointInto<>-1) and FController.FCurrentThread.RemoveWatchpoint(FHiddenWatchpointInto) then
412     FHiddenWatchpointInto:=-1;
413   if (FHiddenWatchpointOutStackbase<>-1) and FController.FCurrentThread.RemoveWatchpoint(FHiddenWatchpointOutStackbase) then
414     FHiddenWatchpointOutStackbase:=-1;
415 
416   AStackPointerValue:=FController.CurrentThread.GetStackPointerRegisterValue;
417   AStackBasePointerValue:=FController.CurrentThread.GetStackBasePointerRegisterValue;
418 
419   Handled := false;
420   Finished := not (AnEvent in [deInternalContinue, deLoadLibrary]);
421   if (AnEvent=deBreakpoint) and (not assigned(FController.FCurrentProcess.CurrentBreakpoint) or (FController.FCurrentProcess.CurrentBreakpoint=FHiddenBreakpoint)) then
422   begin
423     if FController.FCurrentThread.CompareStepInfo<>dcsiNewLine then
424     begin
425       AnEvent:=deInternalContinue;
426       Finished:=false;
427       inc(FInstCount);
428 
429       if FInto then
430       begin
431         if (FController.CurrentProcess.CurrentBreakpoint=FHiddenBreakpoint) then
432         begin
433           FInto:=false;
434           FInstCount:=0;
435           FController.CurrentProcess.RemoveBreak(FHiddenBreakpoint);
436           FreeAndNil(FHiddenBreakpoint);
437         end
438         else
439         begin
440           if FInstCount=1 then
441             FAssumedProcStartStackPointer:=AStackPointerValue;
442           if (AStackBasePointerValue<>FLastStackBaseValue) or (AStackPointerValue<>FLastStackPointerValue) then
443             FInstCount:=1;
444 
445           if FInstCount>4 then
446             SetHWBreakpoints;
447         end;
448       end
449       else
450         FInstCount := 0;
451     end
452     else
453     begin
454       // Also check if the current instruction is at the start of a new
455       // sourceline. (Dwarf only)
456       // Don't do this while stepping into a procedure, only when stepping out.
457       // This because when stepping out of a procedure, the first asm-instruction
458       // could still be part of the instruction-line that made the call to the
459       // procedure in the first place.
460       if ((FStoredStackFrame<AStackBasePointerValue) or (FController.NextOnlyStopOnStartLine))
461         and not FController.FCurrentThread.IsAtStartOfLine then
462       begin
463         Finished:=false;
464         AnEvent:=deInternalContinue;
465       end;
466     end;
467   end;
468   FLastStackPointerValue:=AStackPointerValue;
469   FLastStackBaseValue:=AStackBasePointerValue;
470 end;
471 
472 { TDbgControllerStepOverLineCmd }
473 
474 procedure TDbgControllerStepOverLineCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
475 begin
476   if not FInfoStored then
477   begin
478     FInfoStored:=true;
479     AThread.StoreStepInfo;
480     FStoredStackFrame:=AThread.GetStackBasePointerRegisterValue;
481   end;
482 
483   inherited DoContinue(AProcess, AThread);
484 end;
485 
486 procedure TDbgControllerStepOverLineCmd.ResolveEvent(var AnEvent: TFPDEvent; out Handled, Finished: boolean);
487 begin
488   inherited ResolveEvent(AnEvent, Handled, Finished);
489   if (AnEvent=deBreakpoint) and not assigned(FController.CurrentProcess.CurrentBreakpoint) then
490   begin
491     if (FController.FCurrentThread.CompareStepInfo<>dcsiNewLine) or
492       (not FController.FCurrentThread.IsAtStartOfLine and
493        (FController.NextOnlyStopOnStartLine or (FStoredStackFrame < FController.CurrentThread.GetStackBasePointerRegisterValue))) then
494     begin
495       AnEvent:=deInternalContinue;
496       FHiddenBreakpoint:=nil;
497       FIsSet:=false;
498       Finished:=false;
499     end;
500   end;
501 end;
502 
503 
504 { TDbgControllerStepOverInstructionCmd }
505 
506 procedure TDbgControllerStepOverInstructionCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
507 
508 var
509   CodeBin: array[0..20] of byte;
510   p: pointer;
511   ADump,
512   AStatement: string;
513   CallInstr: boolean;
514   ALocation: TDbgPtr;
515 
516 begin
517   if FIsSet then
518     AProcess.Continue(AProcess, AThread, false)
519   else
520   begin
521     CallInstr:=false;
522     if AProcess.ReadData(AThread.GetInstructionPointerRegisterValue,sizeof(CodeBin),CodeBin) then
523     begin
524       p := @CodeBin;
525       Disassemble(p, AProcess.Mode=dm64, ADump, AStatement);
526       if copy(AStatement,1,4)='call' then
527         CallInstr:=true;
528     end;
529 
530     if CallInstr then
531     begin
532       ALocation := AThread.GetInstructionPointerRegisterValue+(PtrUInt(p)-PtrUInt(@codebin));
533       if not AProcess.HasBreak(ALocation) then
534         FHiddenBreakpoint := AProcess.AddBreak(ALocation);
535     end;
536     FIsSet:=true;
537     AProcess.Continue(AProcess, AThread, not CallInstr);
538   end;
539 end;
540 
541 procedure TDbgControllerStepOverInstructionCmd.ResolveEvent(
542   var AnEvent: TFPDEvent; out Handled, Finished: boolean);
543 begin
544   Handled := false;
545   Finished := not (AnEvent in [deInternalContinue, deLoadLibrary]);
546   if Finished then
547   begin
548     if assigned(FHiddenBreakpoint) then
549     begin
550       FController.FCurrentProcess.RemoveBreak(FHiddenBreakpoint);
551       FHiddenBreakpoint.Free;
552     end;
553   end;
554 end;
555 
556 { TDbgControllerStepIntoInstructionCmd }
557 
558 procedure TDbgControllerStepIntoInstructionCmd.DoContinue(
559   AProcess: TDbgProcess; AThread: TDbgThread);
560 begin
561   AProcess.Continue(AProcess, AThread, True);
562 end;
563 
564 procedure TDbgControllerStepIntoInstructionCmd.ResolveEvent(
565   var AnEvent: TFPDEvent; out Handled, Finished: boolean);
566 begin
567   Handled := false;
568   Finished := (AnEvent<>deInternalContinue);
569 end;
570 
571 { TDbgControllerContinueCmd }
572 
573 procedure TDbgControllerContinueCmd.DoContinue(AProcess: TDbgProcess; AThread: TDbgThread);
574 begin
575   AProcess.Continue(AProcess, AThread, False);
576 end;
577 
578 procedure TDbgControllerContinueCmd.ResolveEvent(var AnEvent: TFPDEvent; out
579   Handled, Finished: boolean);
580 begin
581   Handled := false;
582   Finished := (AnEvent<>deInternalContinue);
583 end;
584 
585 { TDbgControllerCmd }
586 
587 constructor TDbgControllerCmd.Create(AController: TDbgController);
588 begin
589   FController := AController;
590 end;
591 
592 { TDbgController }
593 
594 procedure TDbgController.DoOnDebugInfoLoaded(Sender: TObject);
595 begin
596   if Assigned(FOnDebugInfoLoaded) then
597     FOnDebugInfoLoaded(Self);
598 end;
599 
600 procedure TDbgController.SetParams(AValue: TStringList);
601 begin
602   if FParams=AValue then Exit;
603   FParams.Assign(AValue);
604 end;
605 
606 procedure TDbgController.SetExecutableFilename(AValue: string);
607 begin
608   if FExecutableFilename=AValue then Exit;
609   FExecutableFilename:=AValue;
610 end;
611 
612 procedure TDbgController.SetEnvironment(AValue: TStrings);
613 begin
614   if FEnvironment=AValue then Exit;
615   FEnvironment.Assign(AValue);
616 end;
617 
618 procedure TDbgController.SetOnLog(AValue: TOnLog);
619 begin
620   if FOnLog=AValue then Exit;
621   FOnLog:=AValue;
622 end;
623 
624 destructor TDbgController.Destroy;
625 var
626   it: TMapIterator;
627   p: TDbgProcess;
628 begin
629   if Assigned(FMainProcess) then begin
630     FProcessMap.Delete(FMainProcess.ProcessID);
631     FMainProcess.Free;
632   end;
633 
634   it := TMapIterator.Create(FProcessMap);
635   while not it.EOM do begin
636     it.GetData(p);
637     p.Free;
638     it.Next;
639   end;
640   it.Free;
641   FProcessMap.Free;
642 
643   FParams.Free;
644   FEnvironment.Free;
645   inherited Destroy;
646 end;
647 
648 procedure TDbgController.InitializeCommand(ACommand: TDbgControllerCmd);
649 begin
650   if assigned(FCommand) then
651     raise exception.create('Prior command not finished yet.');
652   {$ifdef DBG_FPDEBUG_VERBOSE}
653   log('Initialized command '+ACommand.ClassName, dllDebug);
654   {$endif DBG_FPDEBUG_VERBOSE}
655   FCommand := ACommand;
656 end;
657 
Runnull658 function TDbgController.Run: boolean;
659 begin
660   result := False;
661   if assigned(FMainProcess) then
662     begin
663     Log('The debuggee is already running', dllInfo);
664     Exit;
665     end;
666 
667   if FExecutableFilename = '' then
668     begin
669     Log('No filename given to execute.', dllInfo);
670     Exit;
671     end;
672 
673   if not FileExists(FExecutableFilename) then
674     begin
675     Log('File %s does not exist.',[FExecutableFilename], dllInfo);
676     Exit;
677     end;
678 
679   FCurrentProcess := OSDbgClasses.DbgProcessClass.StartInstance(FExecutableFilename, Params, Environment, WorkingDirectory, FConsoleTty , @Log, RedirectConsoleOutput);
680   if assigned(FCurrentProcess) then
681     begin
682     FProcessMap.Add(FCurrentProcess.ProcessID, FCurrentProcess);
683     Log('Got PID: %d, TID: %d', [FCurrentProcess.ProcessID, FCurrentProcess.ThreadID]);
684     result := true;
685     end;
686 end;
687 
688 procedure TDbgController.Stop;
689 begin
690   if assigned(FMainProcess) then
691     FMainProcess.TerminateProcess
692   else
693     raise Exception.Create('Failed to stop debugging. No main process.');
694 end;
695 
696 procedure TDbgController.StepIntoInstr;
697 begin
698   InitializeCommand(TDbgControllerStepIntoInstructionCmd.Create(self));
699 end;
700 
701 procedure TDbgController.StepOverInstr;
702 begin
703   InitializeCommand(TDbgControllerStepOverInstructionCmd.Create(self));
704 end;
705 
706 procedure TDbgController.Next;
707 begin
708   InitializeCommand(TDbgControllerStepOverLineCmd.Create(self));
709 end;
710 
711 procedure TDbgController.Step;
712 begin
713   InitializeCommand(TDbgControllerStepIntoLineCmd.Create(self));
714 end;
715 
716 procedure TDbgController.StepOut;
717 begin
718   InitializeCommand(TDbgControllerStepOutInstructionCmd.Create(self));
719 end;
720 
TDbgController.Pausenull721 function TDbgController.Pause: boolean;
722 begin
723   result := FCurrentProcess.Pause;
724 end;
725 
726 procedure TDbgController.ProcessLoop;
727 
728 var
729   AProcessIdentifier: THandle;
730   AThreadIdentifier: THandle;
731   AExit: boolean;
732   IsHandled: boolean;
733   IsFinished: boolean;
734 
735 begin
736   AExit:=false;
737   repeat
738     if assigned(FCurrentProcess) and not assigned(FMainProcess) then
739       FMainProcess:=FCurrentProcess
740     else
741     begin
742       if not assigned(FCommand) then
743         begin
744         {$ifdef DBG_FPDEBUG_VERBOSE}
745         log('Continue process without command.', dllDebug);
746         {$endif DBG_FPDEBUG_VERBOSE}
747         FCurrentProcess.Continue(FCurrentProcess, FCurrentThread, False)
748         end
749       else
750         begin
751         {$ifdef DBG_FPDEBUG_VERBOSE}
752         log('Continue process with command '+FCommand.ClassName, dllDebug);
753         {$endif DBG_FPDEBUG_VERBOSE}
754         FCommand.DoContinue(FCurrentProcess, FCurrentThread);
755         end;
756     end;
757     if not FCurrentProcess.WaitForDebugEvent(AProcessIdentifier, AThreadIdentifier) then Continue;
758 
759     FCurrentProcess := nil;
760     FCurrentThread := nil;
761     if not GetProcess(AProcessIdentifier, FCurrentProcess) then
762       begin
763       // A second/third etc process has been started.
764       (* A process was created/forked
765          However the debugger currently does not attach to it on all platforms
766            so maybe other processes should be ignored?
767            It seems on windows/linux it does NOT attach.
768            On Mac, it may attempt to attach.
769          If the process is not debugged, it may not receive an deExitProcess
770       *)
771       FCurrentProcess := OSDbgClasses.DbgProcessClass.Create('', AProcessIdentifier, AThreadIdentifier, OnLog);
772       FProcessMap.Add(AProcessIdentifier, FCurrentProcess);
773       Continue;
774       end;
775 
776     if FCurrentProcess<>FMainProcess then
777       // Just continue the process. Only the main-process is being debugged.
778       Continue;
779 
780     if not FCurrentProcess.GetThread(AThreadIdentifier, FCurrentThread) then
781       FCurrentThread := FCurrentProcess.AddThread(AThreadIdentifier);
782 
783     FPDEvent:=FCurrentProcess.ResolveDebugEvent(FCurrentThread);
784     {$ifdef DBG_FPDEBUG_VERBOSE}
785     log('Process stopped with event %s. IP=%s, SP=%s, BSP=%s.', [FPDEventNames[FPDEvent],
786                                                                 FCurrentProcess.FormatAddress(FCurrentThread.GetInstructionPointerRegisterValue),
787                                                                 FCurrentProcess.FormatAddress(FCurrentThread.GetStackPointerRegisterValue),
788                                                                 FCurrentProcess.FormatAddress(FCurrentThread.GetStackBasePointerRegisterValue)], dllDebug);
789     {$endif DBG_FPDEBUG_VERBOSE}
790     if assigned(FCommand) then
791       begin
792       FCommand.ResolveEvent(FPDEvent, IsHandled, IsFinished);
793       {$ifdef DBG_FPDEBUG_VERBOSE}
794       if IsFinished then
795         log('Command %s is finished. (IsHandled=%s)', [FCommand.ClassName, BoolToStr(IsHandled)], dllDebug)
796       else
797         log('Command %s is not finished. (IsHandled=%s)', [FCommand.ClassName, BoolToStr(IsHandled)], dllDebug);
798       {$endif DBG_FPDEBUG_VERBOSE}
799       end
800     else
801     begin
802       IsHandled:=false;
803       IsFinished:=false;
804     end;
805     AExit:=true;
806     if not IsHandled then
807     begin
808      case FPDEvent of
809        deInternalContinue: AExit := False;
810 {        deLoadLibrary :
811           begin
812             if FCurrentProcess.GetLib(FCurrentProcess.LastEventProcessIdentifier, ALib)
813             and (GImageInfo <> iiNone)
814             then begin
815               WriteLN('Name: ', ALib.Name);
816               //if GImageInfo = iiDetail
817               //then DumpPEImage(Proc.Handle, Lib.BaseAddr);
818             end;
819             if GBreakOnLibraryLoad
820             then GState := dsPause;
821 
822           end; }
823       end; {case}
824     end;
825     if IsFinished then
826       FreeAndNil(FCommand);
827   until AExit;
828 end;
829 
830 procedure TDbgController.SendEvents(out continue: boolean);
831 begin
832   case FPDEvent of
833     deCreateProcess:
834       begin
835         FCurrentProcess.LoadInfo;
836         if not FCurrentProcess.DbgInfo.HasInfo then
837           Log('No Dwarf-debug information available. The debugger will not function properly. [CurrentProcess='+dbgsname(FCurrentProcess)+',DbgInfo='+dbgsname(FCurrentProcess.DbgInfo)+']',dllInfo);
838 
839         DoOnDebugInfoLoaded(self);
840 
841         continue:=true;
842         if assigned(OnCreateProcessEvent) then
843           OnCreateProcessEvent(continue);
844       end;
845     deBreakpoint:
846       begin
847         continue:=false;
848         if assigned(OnHitBreakpointEvent) then
849           OnHitBreakpointEvent(continue, FCurrentProcess.CurrentBreakpoint);
850       end;
851     deExitProcess:
852       begin
853         if FCurrentProcess = FMainProcess then FMainProcess := nil;
854 
855         if assigned(OnProcessExitEvent) then
856           OnProcessExitEvent(FCurrentProcess.ExitCode);
857 
858         FProcessMap.Delete(FCurrentProcess.ProcessID);
859         FCurrentProcess.Free;
860         FCurrentProcess := nil;
861         continue := false;
862       end;
863     deException:
864       begin
865         continue:=false;
866         if assigned(OnExceptionEvent) then
867           OnExceptionEvent(continue, FCurrentProcess.ExceptionClass, FCurrentProcess.ExceptionMessage );
868       end;
869     deLoadLibrary:
870       begin
871         continue:=true;
872       end;
873     deInternalContinue:
874       begin
875         continue := true;
876       end;
877     else
878       raise exception.create('Unknown debug controler state');
879   end;
880 end;
881 
882 procedure TDbgController.Log(const AString: string; const ALogLevel: TFPDLogLevel);
883 begin
884   if assigned(FOnLog) then
885     FOnLog(AString, ALogLevel)
886   else
887     DebugLn(AString);
888 end;
889 
890 procedure TDbgController.Log(const AString: string;
891   const Options: array of const; const ALogLevel: TFPDLogLevel);
892 begin
893   Log(Format(AString, Options), ALogLevel);
894 end;
895 
GetProcessnull896 function TDbgController.GetProcess(const AProcessIdentifier: THandle; out AProcess: TDbgProcess): Boolean;
897 begin
898   Result := FProcessMap.GetData(AProcessIdentifier, AProcess) and (AProcess <> nil);
899 end;
900 
901 constructor TDbgController.Create;
902 begin
903   FParams := TStringList.Create;
904   FEnvironment := TStringList.Create;
905   FProcessMap := TMap.Create(itu4, SizeOf(TDbgProcess));
906   FNextOnlyStopOnStartLine := true;
907 end;
908 
909 end.
910 
911