FpDebug:

* Added TDbgController class to FpDebug to make it easiear
   to implement a debugger. 
 * Added the package LazFpDebug, which registers a new
   debugger into the IDE that uses FpDebug to debug applications. 

git-svn-id: trunk@44606 -

.gitattributes

@@ -1266,6 +1266,7 @@ components/fpdebug/app/fpd/fpdtype.pas svneol=native#text/pascal
 components/fpdebug/app/fpdd/fpdumpdwarf.lpi svneol=native#text/plain
 components/fpdebug/app/fpdd/fpdumpdwarf.lpr svneol=native#text/pascal
 components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal
+components/fpdebug/fpdbgcontroller.pas svneol=native#text/plain
 components/fpdebug/fpdbgdarwinclasses.pas svneol=native#text/plain
 components/fpdebug/fpdbgdisasx86.pp svneol=native#text/plain
 components/fpdebug/fpdbgdwarf.pas svneol=native#text/pascal
@@ -1293,6 +1294,9 @@ components/fpdebug/fpimgreaderwinpe.pas svneol=native#text/pascal
 components/fpdebug/fpimgreaderwinpetypes.pas svneol=native#text/pascal
 components/fpdebug/fppascalbuilder.pas svneol=native#text/pascal
 components/fpdebug/fppascalparser.pas svneol=native#text/pascal
+components/fpdebug/laz/fpdebugdebugger.pas svneol=native#text/plain
+components/fpdebug/laz/lazfpdebug.lpk svneol=native#text/plain
+components/fpdebug/laz/lazfpdebug.pas svneol=native#text/plain
 components/fpdebug/macho.pas svneol=native#text/pascal
 components/fpdebug/test/FpTest.lpi svneol=native#text/pascal
 components/fpdebug/test/FpTest.lpr svneol=native#text/pascal

components/fpdebug/fpdbgcontroller.pas

@@ -0,0 +1,263 @@
+unit FPDbgController;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes,
+  SysUtils,
+  Maps,
+  FpDbgUtil,
+  LazLogger,
+  FpDbgClasses;
+
+type
+
+  TOnCreateProcessEvent = procedure(var continue: boolean) of object;
+  TOnHitBreakpointEvent = procedure(var continue: boolean) of object;
+  TOnExceptionEvent = procedure(var continue: boolean) of object;
+  TOnProcessExitEvent = procedure(ExitCode: DWord) of object;
+
+  { TDbgController }
+
+  TDbgController = class
+  private
+    FExecutableFilename: string;
+    FOnCreateProcessEvent: TOnCreateProcessEvent;
+    FOnExceptionEvent: TOnExceptionEvent;
+    FOnHitBreakpointEvent: TOnHitBreakpointEvent;
+    FOnLog: TOnLog;
+    FOnProcessExitEvent: TOnProcessExitEvent;
+    FProcessMap: TMap;
+    FExitCode: DWord;
+    FPDEvent: TFPDEvent;
+    procedure SetExecutableFilename(AValue: string);
+    procedure SetOnLog(AValue: TOnLog);
+  protected
+    FMainProcess: TDbgProcess;
+    FCurrentProcess: TDbgProcess;
+    FCurrentThread: TDbgThread;
+    procedure Log(AString: string);
+    procedure Log(AString: string; Options: array of const);
+    function GetProcess(const AProcessIdentifier: THandle; out AProcess: TDbgProcess): Boolean;
+  public
+    constructor Create; virtual;
+    destructor Destroy; override;
+    function Run: boolean;
+    procedure Stop;
+    procedure ProcessLoop;
+    procedure SendEvents(out continue: boolean);
+
+    property ExecutableFilename: string read FExecutableFilename write SetExecutableFilename;
+    property OnLog: TOnLog read FOnLog write SetOnLog;
+    property CurrentProcess: TDbgProcess read FCurrentProcess;
+    property MainProcess: TDbgProcess read FMainProcess;
+
+    property OnCreateProcessEvent: TOnCreateProcessEvent read FOnCreateProcessEvent write FOnCreateProcessEvent;
+    property OnHitBreakpointEvent: TOnHitBreakpointEvent read FOnHitBreakpointEvent write FOnHitBreakpointEvent;
+    property OnProcessExitEvent: TOnProcessExitEvent read FOnProcessExitEvent write FOnProcessExitEvent;
+    property OnExceptionEvent: TOnExceptionEvent read FOnExceptionEvent write FOnExceptionEvent;
+  end;
+
+implementation
+
+{ TDbgController }
+
+procedure TDbgController.SetExecutableFilename(AValue: string);
+begin
+  if FExecutableFilename=AValue then Exit;
+  FExecutableFilename:=AValue;
+end;
+
+procedure TDbgController.SetOnLog(AValue: TOnLog);
+begin
+  if FOnLog=AValue then Exit;
+  FOnLog:=AValue;
+  //if Assigned(FCurrentProcess) then
+  //  FCurrentProcess.OnLog:=FOnLog;
+end;
+
+destructor TDbgController.Destroy;
+begin
+  //FCurrentProcess.Free;
+  inherited Destroy;
+end;
+
+function TDbgController.Run: boolean;
+begin
+  result := False;
+  if assigned(FMainProcess) then
+    begin
+    Log('The debuggee is already running');
+    Exit;
+    end;
+
+  if FExecutableFilename = '' then
+    begin
+    Log('No filename given to execute.');
+    Exit;
+    end;
+
+  if not FileExists(FExecutableFilename) then
+    begin
+    Log('File %s does not exist.',[FExecutableFilename]);
+    Exit;
+    end;
+
+  FCurrentProcess := OSDbgClasses.DbgProcessClass.StartInstance(FExecutableFilename, '');
+  FCurrentProcess.OnLog:=OnLog;
+  if assigned(FCurrentProcess) then
+    begin
+    Log('Got PID: %d, TID: %d', [FCurrentProcess.ProcessID, FCurrentProcess.ThreadID]);
+    result := true;
+    end;
+end;
+
+procedure TDbgController.Stop;
+begin
+  FMainProcess.TerminateProcess;
+end;
+
+procedure TDbgController.ProcessLoop;
+
+var
+  AFirstLoop: boolean;
+  AProcessIdentifier: THandle;
+  AThreadIdentifier: THandle;
+  AExit: boolean;
+  AState: TFPDState;
+
+begin
+  AExit:=false;
+  repeat
+    if assigned(FCurrentProcess) and not assigned(FMainProcess) then
+      begin
+      FMainProcess:=FCurrentProcess;
+      AFirstLoop:=true;
+      end
+    else
+      begin
+      AFirstLoop:=false;
+      FCurrentProcess.Continue(FCurrentProcess, FCurrentThread, AState);
+      end;
+
+    if not FCurrentProcess.WaitForDebugEvent(AProcessIdentifier, AThreadIdentifier) then Continue;
+
+    FCurrentProcess := nil;
+    FCurrentThread := nil;
+    if not GetProcess(AProcessIdentifier, FCurrentProcess) and not AFirstLoop then Continue;
+
+    if AFirstLoop then
+      FCurrentProcess := FMainProcess;
+
+    if not FCurrentProcess.GetThread(AThreadIdentifier, FCurrentThread)
+    then Log('LOOP: Unable to retrieve current thread');
+
+    FPDEvent:=FCurrentProcess.ResolveDebugEvent(FCurrentThread);
+    case FPDEvent of
+      deCreateProcess :
+        begin
+          FProcessMap.Add(AProcessIdentifier, FCurrentProcess);
+        end;
+      deExitProcess :
+        begin
+          if FCurrentProcess = FMainProcess then FMainProcess := nil;
+          FExitCode:=FCurrentProcess.ExitCode;
+
+          FProcessMap.Delete(AProcessIdentifier);
+          FCurrentProcess.Free;
+        end;
+      deLoadLibrary :
+        begin
+          {if FCurrentProcess.GetLib(FCurrentProcess.LastEventProcessIdentifier, ALib)
+          and (GImageInfo <> iiNone)
+          then begin
+            WriteLN('Name: ', ALib.Name);
+            //if GImageInfo = iiDetail
+            //then DumpPEImage(Proc.Handle, Lib.BaseAddr);
+          end;
+          if GBreakOnLibraryLoad
+          then GState := dsPause;
+          }
+        end;
+      deBreakpoint :
+        begin
+          debugln('Reached breakpoint at %s.',[FormatAddress(FCurrentProcess.GetInstructionPointerRegisterValue)]);
+        end;
+    end; {case}
+    AExit:=true;
+  until AExit;
+end;
+
+procedure TDbgController.SendEvents(out continue: boolean);
+begin
+  case FPDEvent of
+    deCreateProcess:
+      begin
+        debugln('Create Process');
+        continue:=true;
+        if assigned(OnCreateProcessEvent) then
+          OnCreateProcessEvent(continue);
+      end;
+    deBreakpoint:
+      begin
+        debugln('Breakpoint');
+        continue:=false;
+        if assigned(OnHitBreakpointEvent) then
+          OnHitBreakpointEvent(continue);
+      end;
+    deExitProcess:
+      begin
+        debugln('Exit proces');
+        continue := false;
+        if assigned(OnProcessExitEvent) then
+          OnProcessExitEvent(FExitCode);
+      end;
+    deException:
+      begin
+        debugln('Exception');
+        continue:=false;
+        if assigned(OnExceptionEvent) then
+          OnExceptionEvent(continue);
+      end;
+    deLoadLibrary:
+      begin
+        debugln('LoadLibrary');
+        continue:=false;
+      end;
+    deInternalContinue:
+      begin
+        debugln('Internal');
+        continue := true;
+      end;
+    else
+      raise exception.create('Unknown debug controler state');
+  end;
+end;
+
+procedure TDbgController.Log(AString: string);
+begin
+  if assigned(@FOnLog) then
+    FOnLog(AString)
+  else
+    DebugLn(AString);
+end;
+
+procedure TDbgController.Log(AString: string; Options: array of const);
+begin
+  OnLog(Format(AString, Options));
+end;
+
+function TDbgController.GetProcess(const AProcessIdentifier: THandle; out AProcess: TDbgProcess): Boolean;
+begin
+  Result := FProcessMap.GetData(AProcessIdentifier, AProcess) and (AProcess <> nil);
+end;
+
+constructor TDbgController.Create;
+begin
+  FProcessMap := TMap.Create(itu4, SizeOf(TDbgProcess));
+end;
+
+end.
+

components/fpdebug/fpdebug.lpk

@@ -34,7 +34,7 @@ File(s) with other licenses (see also header in file(s):
 
   (Any modifications/translations of this file are from duby)
 "/>
-    <Files Count="26">
+    <Files Count="27">
       <Item1>
         <Filename Value="fpdbgclasses.pp"/>
         <UnitName Value="FpDbgClasses"/>
@@ -131,17 +131,21 @@ File(s) with other licenses (see also header in file(s):
         <UnitName Value="FpErrorMessages"/>
       </Item23>
       <Item24>
-        <Filename Value="fpdbgdwarfverboseprinter.pas"/>
-        <UnitName Value="FpDbgDwarfVerbosePrinter"/>
+        <Filename Value="fpdbgcontroller.pas"/>
+        <UnitName Value="FPDbgController"/>
       </Item24>
       <Item25>
-        <Filename Value="fpdbgdwarfdataclasses.pas"/>
-        <UnitName Value="FpDbgDwarfDataClasses"/>
+        <Filename Value="fpdbgdwarfverboseprinter.pas"/>
+        <UnitName Value="FpDbgDwarfVerbosePrinter"/>
       </Item25>
       <Item26>
+        <Filename Value="fpdbgdwarfdataclasses.pas"/>
+        <UnitName Value="FpDbgDwarfDataClasses"/>
+      </Item26>
+      <Item27>
         <Filename Value="fpdbgdwarffreepascal.pas"/>
         <UnitName Value="fpdbgdwarffreepascal"/>
-      </Item26>
+      </Item27>
     </Files>
     <Type Value="RunAndDesignTime"/>
     <RequiredPkgs Count="3">

components/fpdebug/fpdebug.pas

@@ -7,10 +7,11 @@ unit fpdebug;
 interface
 
 uses
-  FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, FpDbgPETypes, 
-  FpDbgSymbols, FpDbgUtil, FpImgReaderWinPE, FpImgReaderElf, FpImgReaderElfTypes, 
-  FpImgReaderBase, FpPascalParser, macho, FpImgReaderMachoFile, FpImgReaderMacho, 
-  FpPascalBuilder, FpDbgInfo, FpdMemoryTools, FpErrorMessages, FpDbgDwarfVerbosePrinter, 
+  FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, 
+  FpDbgPETypes, FpDbgSymbols, FpDbgUtil, FpImgReaderWinPE, FpImgReaderElf, 
+  FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, 
+  FpImgReaderMachoFile, FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, 
+  FpdMemoryTools, FpErrorMessages, FPDbgController, FpDbgDwarfVerbosePrinter, 
   FpDbgDwarfDataClasses, FpDbgDwarfFreePascal, LazarusPackageIntf;
 
 implementation

components/fpdebug/laz/fpdebugdebugger.pas

@@ -0,0 +1,280 @@
+unit FpDebugDebugger;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes,
+  SysUtils,
+  Forms,
+  LazLogger,
+  FpDbgClasses,
+  FpDbgInfo,
+  DbgIntfBaseTypes,
+  DbgIntfDebuggerBase,
+  FPDbgController;
+
+type
+
+  { TFpDebugThread }
+  TFpDebugDebugger = class;
+  TFpDebugThread = class(TThread)
+  private
+    FFpDebugDebugger: TFpDebugDebugger;
+    procedure DoDebugLoopFinishedASync({%H-}Data: PtrInt);
+  public
+    constructor Create(AFpDebugDebugger: TFpDebugDebugger);
+    destructor Destroy; override;
+    procedure Execute; override;
+  end;
+
+  { TFpDebugDebugger }
+
+  TFpDebugDebugger = class(TDebuggerIntf)
+  private
+    FDbgController: TDbgController;
+    FFpDebugThread: TFpDebugThread;
+    FDebugLoopRunning: boolean;
+    procedure FDbgControllerHitBreakpointEvent(var continue: boolean);
+    procedure FDbgControllerCreateProcessEvent(var continue: boolean);
+    procedure FDbgControllerProcessExitEvent(AExitCode: DWord);
+    procedure FDbgControllerExceptionEvent(var continue: boolean);
+  protected
+    function  RequestCommand(const ACommand: TDBGCommand;
+                             const AParams: array of const): Boolean; override;
+    function ChangeFileName: Boolean; override;
+
+    procedure OnLog(AString: String);
+    procedure StartDebugLoop;
+    procedure DebugLoopFinished;
+  public
+    constructor Create(const AExternalDebugger: String); override;
+    destructor Destroy; override;
+    function GetLocation: TDBGLocationRec; override;
+    class function Caption: String; override;
+    class function HasExePath: boolean; override;
+    function  GetSupportedCommands: TDBGCommands; override;
+  end;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+  RegisterDebugger(TFpDebugDebugger);
+end;
+
+{ TFpDebugThread }
+
+procedure TFpDebugThread.DoDebugLoopFinishedASync(Data: PtrInt);
+begin
+  FFpDebugDebugger.DebugLoopFinished;
+end;
+
+constructor TFpDebugThread.Create(AFpDebugDebugger: TFpDebugDebugger);
+begin
+  FFpDebugDebugger := AFpDebugDebugger;
+  inherited Create(false);
+end;
+
+destructor TFpDebugThread.Destroy;
+begin
+  inherited Destroy;
+end;
+
+procedure TFpDebugThread.Execute;
+begin
+  FFpDebugDebugger.FDbgController.ProcessLoop;
+  Application.QueueAsyncCall(@DoDebugLoopFinishedASync, 0);
+end;
+
+{ TFpDebugDebugger }
+
+procedure TFpDebugDebugger.FDbgControllerProcessExitEvent(AExitCode: DWord);
+begin
+  SetExitCode(AExitCode);
+  DoDbgEvent(ecProcess, etProcessExit, Format('Process exited with exit-code %d',[AExitCode]));
+  SetState(dsStop);
+end;
+
+procedure TFpDebugDebugger.FDbgControllerExceptionEvent(var continue: boolean);
+begin
+  DoException(deInternal, 'unknown', GetLocation, 'Unknown exception', continue);
+  if not continue then
+    begin
+    SetState(dsPause);
+    DoCurrent(GetLocation);
+    end;
+end;
+
+procedure TFpDebugDebugger.FDbgControllerHitBreakpointEvent(var continue: boolean);
+begin
+  BreakPoints[0].Hit(continue);
+  SetState(dsPause);
+  DoCurrent(GetLocation);
+end;
+
+procedure TFpDebugDebugger.FDbgControllerCreateProcessEvent(var continue: boolean);
+var
+  i: integer;
+  bp: TDBGBreakPoint;
+  ibp: FpDbgClasses.TDbgBreakpoint;
+begin
+  SetState(dsInit);
+  for i := 0 to BreakPoints.Count-1 do
+    begin
+    bp := BreakPoints.Items[i];
+    if bp.Enabled then
+      begin
+      case bp.Kind of
+        bpkAddress:   ibp := FDbgController.CurrentProcess.AddBreak(bp.Address);
+        bpkSource:    ibp := TDbgInstance(FDbgController.CurrentProcess).AddBreak(bp.Source, cardinal(bp.Line));
+      else
+        Raise Exception.Create('Breakpoints of this kind are not suported.');
+      end;
+      if not assigned(ibp) then
+        begin
+        DoDbgOutput('Failed to set breakpoint '+inttostr(bp.ID));
+        DoOutput('Failed to set breakpoint '+inttostr(bp.ID));
+        //bp.Valid:=vsInvalid;
+        end
+      //else
+        //bp.Valid:=vsValid;
+      end;
+    end;
+end;
+
+function TFpDebugDebugger.RequestCommand(const ACommand: TDBGCommand;
+  const AParams: array of const): Boolean;
+begin
+  result := False;
+  case ACommand of
+    dcRun:
+      begin
+      if not assigned(FDbgController.MainProcess) then
+        begin
+        FDbgController.ExecutableFilename:=FileName;
+        Result := FDbgController.Run;
+        if not Result then
+          Exit;
+        SetState(dsInit);
+        end
+      else
+        begin
+        SetState(dsRun);
+        end;
+      StartDebugLoop;
+      end;
+    dcStop:
+      begin
+        FDbgController.Stop;
+        result := true;
+      end;
+  end; {case}
+end;
+
+function TFpDebugDebugger.ChangeFileName: Boolean;
+begin
+  result := true;
+end;
+
+procedure TFpDebugDebugger.OnLog(AString: String);
+begin
+  DebugLn(AString);
+end;
+
+procedure TFpDebugDebugger.StartDebugLoop;
+begin
+  DebugLn('StartDebugLoop');
+  FDebugLoopRunning:=true;
+  FFpDebugThread := TFpDebugThread.Create(Self);
+end;
+
+procedure TFpDebugDebugger.DebugLoopFinished;
+var
+  Cont: boolean;
+begin
+  FFpDebugThread.WaitFor;
+  FFpDebugThread.Free;
+  FDebugLoopRunning:=false;
+  DebugLn('DebugLoopFinished');
+
+  FDbgController.SendEvents(Cont);
+
+  if Cont then
+    begin
+    SetState(dsRun);
+    StartDebugLoop;
+    end
+end;
+
+constructor TFpDebugDebugger.Create(const AExternalDebugger: String);
+begin
+  inherited Create(AExternalDebugger);
+  FDbgController := TDbgController.Create;
+  FDbgController.OnLog:=@OnLog;
+  FDbgController.OnCreateProcessEvent:=@FDbgControllerCreateProcessEvent;
+  FDbgController.OnHitBreakpointEvent:=@FDbgControllerHitBreakpointEvent;
+  FDbgController.OnProcessExitEvent:=@FDbgControllerProcessExitEvent;
+  FDbgController.OnExceptionEvent:=@FDbgControllerExceptionEvent;
+end;
+
+destructor TFpDebugDebugger.Destroy;
+begin
+  FDbgController.Free;
+  inherited Destroy;
+end;
+
+function TFpDebugDebugger.GetLocation: TDBGLocationRec;
+var
+  sym, symproc: TFpDbgSymbol;
+begin
+  if Assigned(FDbgController.CurrentProcess) then
+    begin
+    result.FuncName:='';
+    result.SrcFile:='';
+    result.SrcFullName:='';
+    result.SrcLine:=0;
+
+    result.Address := FDbgController.CurrentProcess.GetInstructionPointerRegisterValue;
+
+    sym := FDbgController.CurrentProcess.FindSymbol(result.Address);
+    if sym = nil then
+      Exit;
+
+    result.SrcFile := sym.FileName;
+    result.SrcLine := sym.Line;
+    result.SrcFullName := sym.FileName;
+
+    debugln('Locatie: '+sym.FileName+':'+sym.Name+':'+inttostr(sym.Line));
+
+    symproc := sym;
+    while not (symproc.kind in [skProcedure, skFunction]) do
+      symproc := symproc.Parent;
+
+    if assigned(symproc) then
+      result.FuncName:=symproc.Name;
+    end
+  else
+    result := inherited;
+end;
+
+class function TFpDebugDebugger.Caption: String;
+begin
+  Result:='FpDebug internal Dwarf-debugger (alfa)';
+end;
+
+class function TFpDebugDebugger.HasExePath: boolean;
+begin
+  Result:=False;
+end;
+
+function TFpDebugDebugger.GetSupportedCommands: TDBGCommands;
+begin
+  Result:=[dcRun, dcStop];
+end;
+
+end.
+

components/fpdebug/laz/lazfpdebug.lpk

@@ -0,0 +1,49 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Package Version="4">
+    <Name Value="LazFpDebug"/>
+    <Author Value="Joost van der Sluis"/>
+    <CompilerOptions>
+      <Version Value="11"/>
+      <SearchPaths>
+        <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+      </SearchPaths>
+      <Other>
+        <CompilerMessages>
+          <MsgFileName Value=""/>
+        </CompilerMessages>
+        <CompilerPath Value="$(CompPath)"/>
+      </Other>
+    </CompilerOptions>
+    <Description Value="This package adds a stand-alone debugger to the IDE. For now it is only a proof-of-concept. Evaluating data is not (yet) possible."/>
+    <License Value="GPLv2"/>
+    <Files Count="1">
+      <Item1>
+        <Filename Value="fpdebugdebugger.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="FpDebugDebugger"/>
+      </Item1>
+    </Files>
+    <Type Value="RunAndDesignTime"/>
+    <RequiredPkgs Count="3">
+      <Item1>
+        <PackageName Value="fpdebug"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="DebuggerIntf"/>
+      </Item2>
+      <Item3>
+        <PackageName Value="FCL"/>
+      </Item3>
+    </RequiredPkgs>
+    <UsageOptions>
+      <UnitPath Value="$(PkgOutDir)"/>
+    </UsageOptions>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <CustomOptions Items="ExternHelp" Version="2">
+      <_ExternHelp Items="Count"/>
+    </CustomOptions>
+  </Package>
+</CONFIG>

components/fpdebug/laz/lazfpdebug.pas

@@ -0,0 +1,21 @@
+{ This file was automatically created by Lazarus. Do not edit!
+  This source is only used to compile and install the package.
+ }
+
+unit LazFpDebug;
+
+interface
+
+uses
+  FpDebugDebugger, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+  RegisterUnit('FpDebugDebugger', @FpDebugDebugger.Register);
+end;
+
+initialization
+  RegisterPackage('LazFpDebug', @Register);
+end.