paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-10 05:36:10 +02:00
Code Issues Packages Projects Releases Wiki Activity

fpdebug: using Windows W functions

Browse Source 
git-svn-id: branches/fixes_1_6@51582 -
This commit is contained in:
mattias 2016-02-10 19:37:26 +00:00
parent b4b19b35df
commit 7038bee3d1
3 changed files with 41 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
components/fpdebug/fpdbgclasses.pp
View File

@ -195,7 +195,7 @@ type
TDbgInstance = class(TObject)
private
FMode: TFPDMode;
FName: String;
FFileName: String;
FProcess: TDbgProcess;
FSymbolTableInfo: TFpSymbolInfo;
FLoaderList: TDbgImageLoaderList;
@ -203,7 +203,7 @@ type
protected
FDbgInfo: TDbgInfo;
procedure InitializeLoaders; virtual;
procedure SetName(const AValue: String);
procedure SetFileName(const AValue: String);
property LoaderList: TDbgImageLoaderList read FLoaderList write FLoaderList;
public
constructor Create(const AProcess: TDbgProcess); virtual;
@ -229,7 +229,7 @@ type
FBaseAddr: TDBGPtr;
public
constructor Create(const AProcess: TDbgProcess; const ADefaultName: String; const AModuleHandle: THandle; const ABaseAddr: TDbgPtr);
property Name: String read FName;
property Name: String read FFileName;
property ModuleHandle: THandle read FModuleHandle;
property BaseAddr: TDBGPtr read FBaseAddr;
end;
@ -271,7 +271,7 @@ type
function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; virtual; abstract;
public
class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AOnLog: TOnLog; ReDirectOutput: boolean): TDbgProcess; virtual;
constructor Create(const AName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); virtual;
constructor Create(const AFileName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog); virtual;
destructor Destroy; override;
function AddBreak(const ALocation: TDbgPtr): TDbgBreakpoint; overload;
function FindSymbol(const AName: String): TFpDbgSymbol;
@ -312,7 +312,7 @@ type
procedure TerminateProcess; virtual; abstract;
property Handle: THandle read GetHandle;
property Name: String read FName write SetName;
property Name: String read FFileName write SetFileName;
property ProcessID: integer read FProcessID;
property ThreadID: integer read FThreadID;
property ExitCode: DWord read FExitCode;
@ -689,9 +689,9 @@ begin
Result := FProcess.RemoveBreak(addr - AddrOffset);
end;
procedure TDbgInstance.SetName(const AValue: String);
procedure TDbgInstance.SetFileName(const AValue: String);
begin
FName := AValue;
FFileName := AValue;
end;
procedure TDbgInstance.InitializeLoaders;
@ -727,7 +727,7 @@ begin
end;
end;
constructor TDbgProcess.Create(const AName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog);
constructor TDbgProcess.Create(const AFileName: string; const AProcessID, AThreadID: Integer; AOnLog: TOnLog);
const
{.$IFDEF CPU64}
MAP_ID_SIZE = itu8;
@ -747,7 +747,7 @@ begin
FSymInstances := TList.Create;
SetName(AName);
SetFileName(AFileName);
inherited Create(Self);
end;

4
components/fpdebug/fpdbgcontroller.pas
View File

@ -164,7 +164,7 @@ type
property RedirectConsoleOutput: boolean read FRedirectConsoleOutput write FRedirectConsoleOutput;
property ConsoleTty: string read FConsoleTty write FConsoleTty;
// With this parameter set a 'next' will only stop if the current
// instruction is the first inststruction of a line according to the
// instruction is the first instruction of a line according to the
// debuginfo.
// Due to a bug in fpc's debug-info, the line info for the first instruction
// of a line, sometimes points the the prior line. This setting hides the
@ -697,7 +697,7 @@ begin
begin
FCurrentProcess.LoadInfo;
if not FCurrentProcess.DbgInfo.HasInfo then
Log('No Dwarf-debug information available. The debugger will not function properly.',dllInfo);
Log('No Dwarf-debug information available. The debugger will not function properly. [CurrentProcess='+dbgsname(FCurrentProcess)+',DbgInfo='+dbgsname(FCurrentProcess.DbgInfo)+']',dllInfo);
DoOnDebugInfoLoaded(self);

53
components/fpdebug/fpdbgwinclasses.pas
View File

@ -159,55 +159,62 @@ begin
log('FpDbg-ERROR: %s', [GetLastErrorText], dllDebug);
end;
function QueryFullProcessImageName(hProcess:HANDLE; dwFlags: DWord; lpExeName:LPTSTR; var lpdwSize:DWORD):BOOL; stdcall; external 'kernel32' name 'QueryFullProcessImageNameA';
function QueryFullProcessImageName(hProcess:HANDLE; dwFlags: DWord; lpExeName:LPWSTR; var lpdwSize:DWORD):BOOL; stdcall; external 'kernel32' name 'QueryFullProcessImageNameW';
function TDbgWinProcess.GetFullProcessImageName(AProcessHandle: THandle): string;
var
s: string;
u: UnicodeString;
len: DWORD;
begin
len := MAX_PATH;
SetLength(S, len);
if QueryFullProcessImageName(AProcessHandle, 0, @S[1], len)
then SetLength(S, len)
else begin
S := '';
SetLength(u, len);
if QueryFullProcessImageName(AProcessHandle, 0, @u[1], len)
then begin
SetLength(u, len);
Result:=UTF8Encode(u);
end else begin
Result := '';
LogLastError;
end;
result := s;
end;
function TDbgWinProcess.GetModuleFileName(AModuleHandle: THandle): string;
var
u: UnicodeString;
s: string;
len: Integer;
hMod: THandle;
_GetFinalPathNameByHandle: function(hFile: HANDLE; lpFilename:LPTSTR; cchFilePath, dwFlags: DWORD):DWORD; stdcall;
_GetFinalPathNameByHandle: function(hFile: HANDLE; lpFilename:LPWSTR; cchFilePath, dwFlags: DWORD):DWORD; stdcall;
begin
result := '';
// GetFinalPathNameByHandle is only available on Windows Vista / Server 2008
_GetFinalPathNameByHandle := nil;
// normally you would load a lib, but since kernel32 is
// always loaded we can use this (and we don't have to free it
hMod := GetModuleHandle(kernel32);
if hMod = 0 then Exit; //????
pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleA');
// GetFinalPathNameByHandle is only available on Windows Vista / Server 2008
_GetFinalPathNameByHandle := nil;
pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW');
if assigned(_GetFinalPathNameByHandle) then begin
SetLength(S, MAX_PATH);
SetLength(u, MAX_PATH);
len := _GetFinalPathNameByHandle(AModuleHandle, @S[1], MAX_PATH, 0);
len := _GetFinalPathNameByHandle(AModuleHandle, @u[1], MAX_PATH, 0);
s:='';
if len > 0
then SetLength(S, len - 1)
else begin
S := '';
then begin
SetLength(u, len - 1);
if (u<>'') and (u[length(u)]=#0) then
begin
// On some older Windows versions there's a bug in GetFinalPathNameByHandleW,
// which leads to a trailing #0.
Delete(u,length(u),1);
end;
s:=UTF8Encode(u);
end else begin
u := '';
LogLastError;
end;
// On some older Windows versions there's a bug in GetFinalPathNameByHandleA,
// which leads to a trailing #0.
if strutils.RightStr(S,1) =#0 then
SetLength(S,length(S)-1);
// Remove the \\?\ prefix
Delete(S,1,4);
result := S;
@ -261,7 +268,7 @@ begin
s := TDbgWinProcess(AProcess).GetProcFilename(AProcess, AInfo.lpImageName, AInfo.fUnicode, AInfo.hFile);
if s <> ''
then SetName(s);
then SetFileName(s);
LoadInfo;
end;
@ -876,7 +883,7 @@ begin
s := GetProcFilename(Self, AInfo.lpImageName, AInfo.fUnicode, 0);
if s <> ''
then SetName(s);
then SetFileName(s);
end;
function TDbgWinProcess.GetInstructionPointerRegisterValue: TDbgPtr;