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