fpdebug: fix pause on win32

git-svn-id: trunk@49029 -
This commit is contained in:
martin 2015-05-15 15:04:11 +00:00
parent ecf6e6a2a9
commit 24d973001c

View File

@ -904,14 +904,48 @@ begin
end;
function DebugBreakProcess(Process:HANDLE): WINBOOL; external 'kernel32' name 'DebugBreakProcess';
var
DebugBreakAddr: Pointer = nil;
_CreateRemoteThread: function(hProcess: THandle; lpThreadAttributes: Pointer; dwStackSize: DWORD; lpStartAddress: TFNThreadStartRoutine; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall = nil;
procedure InitWin32;
var
hMod: THandle;
begin
// Check if we already are initialized
if DebugBreakAddr <> nil then Exit;
// 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; //????
DebugBreakAddr := GetProcAddress(hMod, 'DebugBreak');
Pointer(_CreateRemoteThread) := GetProcAddress(hMod, 'CreateRemoteThread');
end;
function TDbgWinProcess.Pause: boolean;
var
hndl: Handle;
hThread: THandle;
NewThreadId: Cardinal;
begin
//hndl := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_WRITE or PROCESS_VM_READ, False, TargetPID);
hndl := OpenProcess(PROCESS_ALL_ACCESS, false, ProcessID);
FPauseRequested:=true;
result := DebugBreakProcess(hndl);
if not Result then begin
DebugLn(['pause failed(1) ', GetLastError]);
InitWin32;
hThread := _CreateRemoteThread(hndl, nil, 0, DebugBreakAddr, nil, 0, NewThreadId);
if hThread = 0 then begin
DebugLn(['pause failed(2) ', GetLastError]);
end
else begin
Result := True;
CloseHandle(hThread);
end;
end;
CloseHandle(hndl);
end;