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

adding support for setting name by debugger exception

Browse Source
This commit is contained in:
Pascal Riekenberg 2022-05-12 09:57:04 +02:00
parent db21b090a6
commit 6fbaeda282
1 changed files with 30 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
components/fpdebug/fpdbgwinclasses.pas
View File

@ -123,7 +123,6 @@ uses
type
PPWSTR = ^PWSTR;
TGetThreadDescription = function(threadHandle: THandle; name: PPWSTR): HResult; stdcall;
TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
TFpContextChangeFlag = (ccfControl, ccfInteger);
@ -136,6 +135,8 @@ type
FIsSuspended: Boolean;
FIsSkippingBreakPoint: Boolean;
FIsSkippingBreakPointAddress: TDBGPtr;
FDoNotPollName: Boolean;
FName: String;
protected
FThreadContextChanged: boolean;
FThreadContextChangeFlags: TFpContextChangeFlags;
@ -240,8 +241,6 @@ implementation
var
DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup;
KernelHandle : THandle;
GetThreadDescription: TGetThreadDescription;
{$ifdef cpux86_64}
const
@ -316,6 +315,7 @@ var
_Wow64GetThreadContext: function (hThread: THandle; var lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_Wow64SetThreadContext: function (hThread: THandle; const lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_DebugBreakProcess: function(Process:HANDLE): WINBOOL; stdcall = nil;
_GetThreadDescription: function(hThread: THandle; ppszThreadDescription: PPWSTR): HResult; stdcall = nil;
procedure LoadKernelEntryPoints;
var
@ -333,6 +333,7 @@ begin
Pointer(_DebugActiveProcess) := GetProcAddress(hMod, 'DebugActiveProcess');
Pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW');
Pointer(_DebugBreakProcess) := GetProcAddress(hMod, 'DebugBreakProcess');
Pointer(_GetThreadDescription) := GetProcAddress(hMod, 'GetThreadDescription');
{$ifdef cpux86_64}
Pointer(_IsWow64Process) := GetProcAddress(hMod, 'IsWow64Process');
Pointer(_Wow64GetThreadContext) := GetProcAddress(hMod, 'Wow64GetThreadContext');
@ -346,6 +347,7 @@ begin
DebugLn(DBG_WARNINGS and (_DebugActiveProcess = nil), ['WARNING: Failed to get DebugActiveProcess']);
DebugLn(DBG_WARNINGS and (_GetFinalPathNameByHandle = nil), ['WARNING: Failed to get GetFinalPathNameByHandle']);
DebugLn(DBG_WARNINGS and (_DebugBreakProcess = nil), ['WARNING: Failed to get DebugBreakProcess']);
DebugLn(DBG_WARNINGS and (_GetThreadDescription = nil), ['WARNING: Failed to get GetThreadDescription']);
{$ifdef cpux86_64}
DebugLn(DBG_WARNINGS and (_IsWow64Process = nil), ['WARNING: Failed to get IsWow64Process']);
DebugLn(DBG_WARNINGS and (_Wow64GetThreadContext = nil), ['WARNING: Failed to get Wow64GetThreadContext']);
@ -1251,8 +1253,11 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
OnDebugOutputEvent(Self, AEvent.dwProcessId, AEvent.dwThreadId, S);
end;
const
EXCEPTION_SET_THREADNAME = $406D1388;
var
InterceptAtFirst: Boolean;
threadname: String;
begin
if AThread <> nil then
TDbgWinThread(AThread).EndSingleStepOverBreakPoint;
@ -1279,6 +1284,17 @@ begin
end;
EXCEPTION_SINGLE_STEP, STATUS_WX86_SINGLE_STEP: begin
result := deBreakpoint;
end;
EXCEPTION_SET_THREADNAME: begin
if AThread <> nil then begin
if not ReadString(TDbgPtr(MDebugEvent.Exception.ExceptionRecord.ExceptionInformation[1]), 200, threadname) then
threadname := 'error getting threadname';
with TDbgWinThread(AThread) do begin
FName := threadname;
FDoNotPollName := True;
end;
end;
result := deInternalContinue;
end
else begin
HandleException(MDebugEvent, InterceptAtFirst);
@ -1603,15 +1619,17 @@ function TDbgWinThread.GetName: String;
var
n: PWSTR;
begin
if Assigned(GetThreadDescription) then begin
if Succeeded(GetThreadDescription(Handle, @n)) then begin
Result := WideCharToString(n);
LocalFree(HLOCAL(n));
if Result = '' then
Result := inherited GetName;
end else
Result := inherited GetName;
end else
Result := '';
if FDoNotPollName then begin
Result := FName;
end else begin
if _GetThreadDescription <> nil then
if Succeeded(_GetThreadDescription(Handle, @n)) then begin
Result := WideCharToString(n);
LocalFree(HLOCAL(n));
end;
end;
if Result = '' then
Result := inherited GetName;
end;