unit FpDbgLinuxClasses;

{$mode objfpc}{$H+}
{$packrecords c}

interface

uses
  Classes,
  SysUtils,
  BaseUnix,
  process,
  FpDbgClasses,
  FpDbgLoader,
  DbgIntfBaseTypes,
  FpDbgLinuxExtra,
  FpDbgInfo,
  FpDbgUtil,
  LazLoggerBase;

type
  user_regs_struct64 = record
    r15: cuint64;
    r14: cuint64;
    r13: cuint64;
    r12: cuint64;
    rbp: cuint64;
    rbx: cuint64;
    r11: cuint64;
    r10: cuint64;
    r9 : cuint64;
    r8 : cuint64;
    rax: cuint64;
    rcx: cuint64;
    rdx: cuint64;
    rsi: cuint64;
    rdi: cuint64;
    orig_rax: cuint64;
    rip: cuint64;
    cs : cuint64;
    eflags: cuint64;
    rsp: cuint64;
    ss : cuint64;
    fs_base: cuint64;
    gs_base: cuint64;
    ds : cuint64;
    es : cuint64;
    fs : cuint64;
    gs : cuint64;
  end;

  user_fpregs_struct64 = record
    cwd : word;
    swd : word;
    ftw : word;
    fop : word;
    rip : qword;
    rdp : qword;
    mxcsr : dword;
    mxcr_mask : dword;
    st_space : array[0..31] of dword;
    xmm_space : array[0..63] of dword;
    padding : array[0..23] of dword;
  end;

  user64 = record
    regs : user_regs_struct64;
    u_fpvalid : longint;
    i387 : user_fpregs_struct64;
    u_tsize : qword;
    u_dsize : qword;
    u_ssize : qword;
    start_code : qword;
    start_stack : qword;
    signal : int64;
    reserved : longint;
//  case a: integer of
//    0: (
          u_ar0 : ^user_regs_struct32;
          __u_ar0_word : qword;
//       );
//      1: (u_fpstate : ^user_fpregs_struct32;
//          __u_fpstate_word : qword);
    magic : qword;
    u_comm : array[0..31] of char;
    u_debugreg : array[0..7] of qword;
  end;

  user_regs_struct32 = record
    ebx: cuint32;
    ecx: cuint32;
    edx: cuint32;
    esi: cuint32;
    edi: cuint32;
    ebp: cuint32;
    eax: cuint32;
    xds: cuint32;
    xes: cuint32;
    xfs: cuint32;
    xgs: cuint32;
    orig_eax: cuint32;
    eip: cuint32;
    xcs: cuint32;
    eflags: cuint32;
    esp: cuint32;
    xss: cuint32;
  end;

type

  { TDbgLinuxThread }

  TDbgLinuxThread = class(TDbgThread)
  private
    FUserRegsStruct32: user_regs_struct32;
    FUserRegsStruct64: user_regs_struct64;
    FUserRegsChanged: boolean;
    function ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean;
    function WriteDebugReg(ind: byte; AVal: PtrUInt): boolean;
  protected
    function ReadThreadState: boolean;
  public
    function ResetInstructionPointerAfterBreakpoint: boolean; override;
    function AddWatchpoint(AnAddr: TDBGPtr): integer; override;
    function RemoveWatchpoint(AnId: integer): boolean; override;
    procedure BeforeContinue; override;
    procedure LoadRegisterValues; override;
  end;

  { TDbgLinuxProcess }

  TDbgLinuxProcess = class(TDbgProcess)
  private
    FStatus: cint;
    FProcessStarted: boolean;
    FProcProcess: TProcess;
    FIsTerminating: boolean;
    FExceptionSignal: PtrUInt;
    procedure OnForkEvent(Sender : TObject);
  protected
    function InitializeLoader: TDbgImageLoader; override;
    function CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; override;
    function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override;
  public
    class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory: string; AOnLog: TOnLog): TDbgProcess; override;
    constructor Create(const AName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); override;
    destructor Destroy; override;

    function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; override;
    function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; override;

    function GetInstructionPointerRegisterValue: TDbgPtr; override;
    function GetStackPointerRegisterValue: TDbgPtr; override;
    function GetStackBasePointerRegisterValue: TDbgPtr; override;
    procedure TerminateProcess; override;

    function Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean; override;
    function WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; override;
  end;

procedure RegisterDbgClasses;

implementation

procedure RegisterDbgClasses;
begin
  OSDbgClasses.DbgProcessClass:=TDbgLinuxProcess;
  OSDbgClasses.DbgThreadClass:=TDbgLinuxThread;
end;

Function WIFSTOPPED(Status: Integer): Boolean;
begin
  WIFSTOPPED:=((Status and $FF)=$7F);
end;

{ TDbgLinuxThread }

procedure TDbgLinuxProcess.OnForkEvent(Sender: TObject);
var
  e: integer;
begin
  fpPTrace(PTRACE_TRACEME, 0, nil, nil);
  e := fpgeterrno;
  if e <> 0 then
    begin
    writeln('Failed to start trace of process. Errcode: '+inttostr(e));
    end
end;

function TDbgLinuxThread.ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean;
var
  offset: pointer;
  user64ptr: ^user64;
  e: integer;
begin
  user64ptr:=nil;
  offset := @(user64ptr^.u_debugreg[ind]);
  fpseterrno(0);
  AVal := PtrUInt(fpPTrace(PTRACE_PEEKUSR, Process.ProcessID, offset, nil));
  e := fpgeterrno;
  if e <> 0 then
    begin
    log('Failed to read dr'+inttostr(ind)+'-debug register. Errcode: '+inttostr(e));
    result := false;
    end
  else
    result := true;
end;

function TDbgLinuxThread.WriteDebugReg(ind: byte; AVal: PtrUInt): boolean;
var
  offset: pointer;
  user64ptr: ^user64;
 avalterug: ptruint;
begin
  user64ptr:=nil;
  offset := @(user64ptr^.u_debugreg[ind]);
  if fpPTrace(PTRACE_POKEUSR, Process.ProcessID, offset, pointer(AVal)) = -1 then
    begin
    log('Failed to write dr'+inttostr(ind)+'-debug register. Errcode: '+inttostr(fpgeterrno));
    result := false;
    end
  else
    result := true;

  avalterug := PtrUInt(fpPTrace(PTRACE_PEEKUSR, Process.ProcessID, offset, nil));
end;


function TDbgLinuxThread.ReadThreadState: boolean;
var
  e: integer;
begin
  result := true;
  errno:=0;
  fpPTrace(PTRACE_GETREGS, Process.ProcessID, nil, @FUserRegsStruct64);
  e := fpgeterrno;
  if e <> 0 then
    begin
    log('Failed to read thread registers from processid '+inttostr(Process.ProcessID)+'. Errcode: '+inttostr(e));
    result := false;
    end;
  FUserRegsChanged:=false;
  FRegisterValueListValid:=false;
end;

function TDbgLinuxThread.ResetInstructionPointerAfterBreakpoint: boolean;
begin
  result := true;

  if Process.Mode=dm32 then
    Dec(FUserRegsStruct32.eip)
  else
    Dec(FUserRegsStruct64.rip);
  FUserRegsChanged:=true;
end;

function TDbgLinuxThread.AddWatchpoint(AnAddr: TDBGPtr): integer;
var
  dr7: PtrUInt;

  function SetHWBreakpoint(ind: byte): boolean;
  var
    Addr: PtrUInt;
  begin
    result := false;
    if ((dr7 and (1 shl ind))=0) then
    begin
      if not ReadDebugReg(ind, Addr) or (Addr<>0) then
        Exit;

      dr7 := dr7 or (1 shl (ind*2));
      dr7 := dr7 or ($30000 shl (ind*4));
      if WriteDebugReg(7, dr7) and WriteDebugReg(ind, AnAddr) then
        result := true;
    end;
  end;

var
  i: integer;
begin
  result := -1;
  if not ReadDebugReg(7, dr7) then
    Exit;

  i := 0;
  while (i<4) and not SetHWBreakpoint(i) do
    inc(i);
  if i=4 then
    Process.Log('No hardware breakpoint available.')
  else
    result := i;
end;

function TDbgLinuxThread.RemoveWatchpoint(AnId: integer): boolean;
var
  dr7: PtrUInt;
  addr: PtrUInt;
begin
  result := false;
  if not ReadDebugReg(7, dr7) or not ReadDebugReg(AnId, addr) then
    Exit;

  if (addr<>0) and ((dr7 and (1 shl (AnId*2)))<>0) then
  begin
    dr7 := dr7 xor (1 shl (AnId*2));
    dr7 := dr7 xor ($30000 shl (AnId*4));
    if WriteDebugReg(AnId, 0) and WriteDebugReg(7, dr7) then
      Result := True;
  end
  else
  begin
    Process.Log('HW watchpoint %d is not set.',[AnId]);
  end;
end;

procedure TDbgLinuxThread.BeforeContinue;
var
  e: integer;
begin
  if FUserRegsChanged then
    begin
    fpPTrace(PTRACE_SETREGS, Process.ProcessID, nil, @FUserRegsStruct64);
    e := fpgeterrno;
    if e <> 0 then
      begin
      log('Failed to set thread registers. Errcode: '+inttostr(e));
      end;
    FUserRegsChanged:=false;
    end;
end;

procedure TDbgLinuxThread.LoadRegisterValues;
begin
  if Process.Mode=dm32 then with FUserRegsStruct32 do
  begin
    FRegisterValueList.DbgRegisterAutoCreate['eax'].SetValue(eax, IntToStr(eax),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['ecx'].SetValue(ecx, IntToStr(ecx),4,1);
    FRegisterValueList.DbgRegisterAutoCreate['edx'].SetValue(edx, IntToStr(edx),4,2);
    FRegisterValueList.DbgRegisterAutoCreate['ebx'].SetValue(ebx, IntToStr(ebx),4,3);
    FRegisterValueList.DbgRegisterAutoCreate['esp'].SetValue(esp, IntToStr(esp),4,4);
    FRegisterValueList.DbgRegisterAutoCreate['ebp'].SetValue(ebp, IntToStr(ebp),4,5);
    FRegisterValueList.DbgRegisterAutoCreate['esi'].SetValue(esi, IntToStr(esi),4,6);
    FRegisterValueList.DbgRegisterAutoCreate['edi'].SetValue(edi, IntToStr(edi),4,7);
    FRegisterValueList.DbgRegisterAutoCreate['eip'].SetValue(eip, IntToStr(eip),4,8);

    FRegisterValueList.DbgRegisterAutoCreate['eflags'].Setx86EFlagsValue(eflags);

    FRegisterValueList.DbgRegisterAutoCreate['cs'].SetValue(xcs, IntToStr(xcs),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['ss'].SetValue(xss, IntToStr(xss),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['ds'].SetValue(xds, IntToStr(xds),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['es'].SetValue(xes, IntToStr(xes),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['fs'].SetValue(xfs, IntToStr(xfs),4,0);
    FRegisterValueList.DbgRegisterAutoCreate['gs'].SetValue(xgs, IntToStr(xgs),4,0);
  end else with FUserRegsStruct64 do
    begin
    FRegisterValueList.DbgRegisterAutoCreate['rax'].SetValue(rax, IntToStr(rax),8,0);
    FRegisterValueList.DbgRegisterAutoCreate['rbx'].SetValue(rbx, IntToStr(rbx),8,3);
    FRegisterValueList.DbgRegisterAutoCreate['rcx'].SetValue(rcx, IntToStr(rcx),8,2);
    FRegisterValueList.DbgRegisterAutoCreate['rdx'].SetValue(rdx, IntToStr(rdx),8,1);
    FRegisterValueList.DbgRegisterAutoCreate['rsi'].SetValue(rsi, IntToStr(rsi),8,4);
    FRegisterValueList.DbgRegisterAutoCreate['rdi'].SetValue(rdi, IntToStr(rdi),8,5);
    FRegisterValueList.DbgRegisterAutoCreate['rbp'].SetValue(rbp, IntToStr(rbp),8,6);
    FRegisterValueList.DbgRegisterAutoCreate['rsp'].SetValue(rsp, IntToStr(rsp),8,7);

    FRegisterValueList.DbgRegisterAutoCreate['r8'].SetValue(r8, IntToStr(r8),8,8);
    FRegisterValueList.DbgRegisterAutoCreate['r9'].SetValue(r9, IntToStr(r9),8,9);
    FRegisterValueList.DbgRegisterAutoCreate['r10'].SetValue(r10, IntToStr(r10),8,10);
    FRegisterValueList.DbgRegisterAutoCreate['r11'].SetValue(r11, IntToStr(r11),8,11);
    FRegisterValueList.DbgRegisterAutoCreate['r12'].SetValue(r12, IntToStr(r12),8,12);
    FRegisterValueList.DbgRegisterAutoCreate['r13'].SetValue(r13, IntToStr(r13),8,13);
    FRegisterValueList.DbgRegisterAutoCreate['r14'].SetValue(r14, IntToStr(r14),8,14);
    FRegisterValueList.DbgRegisterAutoCreate['r15'].SetValue(r15, IntToStr(r15),8,15);

    FRegisterValueList.DbgRegisterAutoCreate['rip'].SetValue(rip, IntToStr(rip),8,16);
    FRegisterValueList.DbgRegisterAutoCreate['eflags'].Setx86EFlagsValue(eflags);

    FRegisterValueList.DbgRegisterAutoCreate['cs'].SetValue(cs, IntToStr(cs),8,43);
    FRegisterValueList.DbgRegisterAutoCreate['fs'].SetValue(fs, IntToStr(fs),8,46);
    FRegisterValueList.DbgRegisterAutoCreate['gs'].SetValue(gs, IntToStr(gs),8,47);
  end;
  FRegisterValueListValid:=true;
end;

{ TDbgLinuxProcess }

function TDbgLinuxProcess.InitializeLoader: TDbgImageLoader;
begin
  result := TDbgImageLoader.Create(Name);
end;

function TDbgLinuxProcess.CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread;
begin
  IsMainThread:=true;
  if AthreadIdentifier>-1 then
    result := TDbgLinuxThread.Create(Self, AthreadIdentifier, AthreadIdentifier)
  else
    result := nil;
end;

constructor TDbgLinuxProcess.Create(const AName: string; const AProcessID,
  AThreadID: Integer; AOnLog: TOnLog);
begin
  inherited Create(AName, AProcessID, AThreadID, AOnLog);

  LoadInfo;

  if DbgInfo.HasInfo
  then FSymInstances.Add(Self);
end;

destructor TDbgLinuxProcess.Destroy;
begin
  FProcProcess.Free;
  inherited Destroy;
end;

class function TDbgLinuxProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory: string; AOnLog: TOnLog): TDbgProcess;
var
  PID: TPid;
  AProcess: TProcess;
  AnExecutabeFilename: string;
begin
  result := nil;

  AnExecutabeFilename:=ExcludeTrailingPathDelimiter(AFileName);
  if DirectoryExists(AnExecutabeFilename) then
  begin
    DebugLn(format('Can not debug %s, because it''s a directory',[AnExecutabeFilename]));
    Exit;
  end;

  if not FileExists(AFileName) then
  begin
    DebugLn(format('Can not find  %s.',[AnExecutabeFilename]));
    Exit;
  end;

  AProcess := TProcess.Create(nil);
  try
    AProcess.OnForkEvent:=@OnForkEvent;
    AProcess.Executable:=AnExecutabeFilename;
    AProcess.Parameters:=AParams;
    AProcess.Environment:=AnEnvironment;
    AProcess.CurrentDirectory:=AWorkingDirectory;
    AProcess.Execute;
    PID:=AProcess.ProcessID;

    sleep(100);
    result := TDbgLinuxProcess.Create(AFileName, Pid, -1, AOnLog);
  except
    AProcess.Free;
    raise;
  end;

  TDbgLinuxProcess(result).FProcProcess := AProcess;
end;

function TDbgLinuxProcess.ReadData(const AAdress: TDbgPtr;
  const ASize: Cardinal; out AData): Boolean;

var
  WordSize: byte;

  function ReadWordSize(Adr: TDbgPtr; out AVal: TDBGPtr): boolean;
  var
    e: integer;
  begin
    errno := 0;
    AVal := TDbgPtr(fpPTrace(PTRACE_PEEKDATA, Process.ProcessID, pointer(Adr), nil));
    e := fpgeterrno;
    if e <> 0 then
      begin
      log('Failed to read data at address '+FormatAddress(Adr)+' from processid '+inttostr(Process.ProcessID)+'. Errcode: '+inttostr(e));
      result := false;
      end
    else
      result := true;
  end;

var
  AVal: TDbgPtr;
  AAdressAlign: TDBGPtr;
  BytesRead: integer;
  ReadBytes: integer;
  PB: PByte;
  buf: pbyte;
begin
  BytesRead := 0;
  result := false;
  getmem(buf, ASize);
  try
    WordSize:=DBGPTRSIZE[Mode];
    if AAdress mod WordSize <> 0 then
      begin
      AAdressAlign := ((PtrUInt(AAdress)) and not PtrUInt(WordSize - 1));
      if not ReadWordSize(AAdressAlign, AVal) then
        Exit;
      pb := @AVal;
      BytesRead:=WordSize-(AAdress-AAdressAlign);
      if BytesRead>=ASize then
        BytesRead:=ASize;
      move(pb[AAdress-AAdressAlign], buf[0], BytesRead);
      inc(AAdressAlign, WordSize);
      end
    else
      AAdressAlign:=AAdress;

    while BytesRead<ASize do
      begin
      if not ReadWordSize(AAdressAlign, AVal) then
        exit;
      if WordSize<(ASize-BytesRead) then
        ReadBytes:=WordSize
      else
        ReadBytes:=(ASize-BytesRead);
      move(AVal, buf[BytesRead], ReadBytes);
      inc(BytesRead, ReadBytes);
      inc(AAdressAlign, WordSize);

      end;
    System.Move(buf^, AData, BytesRead);
  finally
    freemem(buf);
  end;
  MaskBreakpointsInReadData(AAdress, ASize, AData);
  result := true;
end;

function TDbgLinuxProcess.WriteData(const AAdress: TDbgPtr;
  const ASize: Cardinal; const AData): Boolean;
var
  e: integer;
  pi: TDBGPtr;
  WordSize: integer;
begin
  result := false;
  WordSize:=DBGPTRSIZE[Mode];

  if ASize>WordSize then
    log('Can not write more then '+IntToStr(WordSize)+' bytes.')
  else
    begin
    if ASize<WordSize then
      begin
      fpseterrno(0);
      pi := TDbgPtr(fpPTrace(PTRACE_PEEKDATA, Process.ProcessID, pointer(AAdress), nil));
      e := fpgeterrno;
      if e <> 0 then
        begin
        log('Failed to read data. Errcode: '+inttostr(e));
        result := false;
        exit;
        end;
      end;
    move(AData, pi, ASize);

    fpPTrace(PTRACE_POKEDATA, Process.ProcessID, pointer(AAdress), pointer(pi));
    e := fpgeterrno;
    if e <> 0 then
      begin
      log('Failed to write data. Errcode: '+inttostr(e));
      result := false;
      end;
    end;

  result := true;
end;

function TDbgLinuxProcess.GetInstructionPointerRegisterValue: TDbgPtr;
begin
  if Mode=dm32 then
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct32.eip
  else
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct64.rip;
end;

function TDbgLinuxProcess.GetStackPointerRegisterValue: TDbgPtr;
begin
  if Mode=dm32 then
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct32.esp
  else
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct64.rsp;
end;

function TDbgLinuxProcess.GetStackBasePointerRegisterValue: TDbgPtr;
begin
  if Mode=dm32 then
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct32.ebp
  else
    result := TDbgLinuxThread(FMainThread).FUserRegsStruct64.rbp;
end;

procedure TDbgLinuxProcess.TerminateProcess;
begin
  FIsTerminating:=true;
  if fpkill(ProcessID,SIGKILL)<>0 then
    begin
    log('Failed to send SIGKILL to process %d. Errno: %d',[ProcessID, errno]);
    FIsTerminating:=false;
    end;
end;

function TDbgLinuxProcess.Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean;
var
  e: integer;
begin
  fpseterrno(0);
  AThread.NextIsSingleStep:=SingleStep;
  AThread.BeforeContinue;
  if SingleStep or assigned(FCurrentBreakpoint) then
    fpPTrace(PTRACE_SINGLESTEP, ProcessID, pointer(1), pointer(FExceptionSignal))
  else if FIsTerminating then
    fpPTrace(PTRACE_KILL, ProcessID, pointer(1), nil)
  else
    fpPTrace(PTRACE_CONT, ProcessID, pointer(1), pointer(FExceptionSignal));
  e := fpgeterrno;
  if e <> 0 then
    begin
    log('Failed to continue process. Errcode: '+inttostr(e));
    result := false;
    end
  else
    result := true;
end;

function TDbgLinuxProcess.WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean;
begin
  ThreadIdentifier:=1;

  ProcessIdentifier:=FpWaitPid(-1, FStatus, 0);

  result := ProcessIdentifier<>-1;
  if not result then
    Log('Failed to wait for debug event. Errcode: %d', [fpgeterrno]);
end;

function TDbgLinuxProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;

begin
  FExceptionSignal:=0;
  if wifexited(FStatus) or wifsignaled(FStatus) then
    begin
    SetExitCode(wexitStatus(FStatus));

    result := deExitProcess
    end
  else if WIFSTOPPED(FStatus) then
    begin
    //log('Stopped ',FStatus, ' signal: ',wstopsig(FStatus));
    TDbgLinuxThread(AThread).ReadThreadState;
    case wstopsig(FStatus) of
      SIGTRAP:
        begin        if not FProcessStarted then
          begin
          result := deCreateProcess;
          FProcessStarted:=true;
          end
        else
          result := deBreakpoint;
        end;
      SIGBUS:
        begin
        ExceptionClass:='SIGBUS';
        FExceptionSignal:=SIGBUS;
        result := deException;
        end;
      SIGINT:
        begin
        ExceptionClass:='SIGINT';
        FExceptionSignal:=SIGINT;
        result := deException;
        end;
      SIGSEGV:
        begin
        ExceptionClass:='SIGSEGV';
        FExceptionSignal:=SIGSEGV;
        result := deException;
        end;
      SIGKILL:
        begin
        if FIsTerminating then
          result := deInternalContinue
        else
          begin
          ExceptionClass:='SIGKILL';
          FExceptionSignal:=SIGKILL;
          result := deException;
          end;
        end;
      else
        begin
        ExceptionClass:='Unknown exception code '+inttostr(wstopsig(FStatus));
        FExceptionSignal:=wstopsig(FStatus);
        result := deException;
        end;
    end; {case}
    if result=deException then
      ExceptionClass:='External: '+ExceptionClass;
    end
  else
    raise exception.CreateFmt('Received unknown status %d from process with pid=%d',[FStatus, ProcessID]);
end;

end.