How can I make AllocateHwnd threadsafe? - delphi

VCL components are designed to be used solely from the main thread of an application. For visual components this never presents me with any difficulties. However, I would sometimes like to be able to use, for example, non-visual components like TTimer from a background thread. Or indeed just create a hidden window. This is not safe because of the reliance on AllocateHwnd. Now, AllocateHwnd is not threadsafe which I understand is by design.
Is there an easy solution that allows me to use AllocateHwnd from a background thread?

This problem can be solved like so:
Obtain or implement a threadsafe version of AllocateHwnd and DeallocateHwnd.
Replace the VCL's unsafe versions of these functions.
For item 1 I use Primož Gabrijelcic's code, as described on his blog article on the subject. For item 2 I simply use the very well-known trick of patching the code at runtime and replacing the beginning of the unsafe routines with unconditional JMP instructions that redirect execution to the threadsafe functions.
Putting it all together results in the following unit.
(* Makes AllocateHwnd safe to call from threads. For example this makes TTimer
safe to use from threads. Include this unit as early as possible in your
.dpr file. It must come after any memory manager, but it must be included
immediately after that before any included unit has an opportunity to call
Classes.AllocateHwnd. *)
unit MakeAllocateHwndThreadsafe;
interface
implementation
{$IF CompilerVersion >= 23}{$DEFINE ScopedUnitNames}{$IFEND}
uses
{$IFDEF ScopedUnitNames}System.SysUtils{$ELSE}SysUtils{$ENDIF},
{$IFDEF ScopedUnitNames}System.Classes{$ELSE}Classes{$ENDIF},
{$IFDEF ScopedUnitNames}Winapi.Windows{$ELSE}Windows{$ENDIF},
{$IFDEF ScopedUnitNames}Winapi.Messages{$ELSE}Messages{$ENDIF};
const //DSiAllocateHwnd window extra data offsets
GWL_METHODCODE = SizeOf(pointer) * 0;
GWL_METHODDATA = SizeOf(pointer) * 1;
//DSiAllocateHwnd hidden window (and window class) name
CDSiHiddenWindowName = 'DSiUtilWindow';
var
//DSiAllocateHwnd lock
GDSiWndHandlerCritSect: TRTLCriticalSection;
//Count of registered windows in this instance
GDSiWndHandlerCount: integer;
//Class message dispatcher for the DSiUtilWindow class. Fetches instance's WndProc from
//the window extra data and calls it.
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
var
instanceWndProc: TMethod;
msg : TMessage;
begin
{$IFDEF CPUX64}
instanceWndProc.Code := pointer(GetWindowLongPtr(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLongPtr(Window, GWL_METHODDATA));
{$ELSE}
instanceWndProc.Code := pointer(GetWindowLong(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLong(Window, GWL_METHODDATA));
{$ENDIF ~CPUX64}
if Assigned(TWndMethod(instanceWndProc)) then
begin
msg.msg := Message;
msg.wParam := WParam;
msg.lParam := LParam;
msg.Result := 0;
TWndMethod(instanceWndProc)(msg);
Result := msg.Result
end
else
Result := DefWindowProc(Window, Message, WParam,LParam);
end; { DSiClassWndProc }
//Thread-safe AllocateHwnd.
// #author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
// TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
// #since 2007-05-30
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
var
alreadyRegistered: boolean;
tempClass : TWndClass;
utilWindowClass : TWndClass;
begin
Result := 0;
FillChar(utilWindowClass, SizeOf(utilWindowClass), 0);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
alreadyRegistered := GetClassInfo(HInstance, CDSiHiddenWindowName, tempClass);
if (not alreadyRegistered) or (tempClass.lpfnWndProc <> #DSiClassWndProc) then begin
if alreadyRegistered then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
utilWindowClass.lpszClassName := CDSiHiddenWindowName;
utilWindowClass.hInstance := HInstance;
utilWindowClass.lpfnWndProc := #DSiClassWndProc;
utilWindowClass.cbWndExtra := SizeOf(TMethod);
if {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.RegisterClass(utilWindowClass) = 0 then
raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',
[SysErrorMessage(GetLastError)]);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, CDSiHiddenWindowName, '', WS_POPUP,
0, 0, 0, 0, 0, 0, HInstance, nil);
if Result = 0 then
raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',
[SysErrorMessage(GetLastError)]);
{$IFDEF CPUX64}
SetWindowLongPtr(Result, GWL_METHODDATA, NativeInt(TMethod(wndProcMethod).Data));
SetWindowLongPtr(Result, GWL_METHODCODE, NativeInt(TMethod(wndProcMethod).Code));
{$ELSE}
SetWindowLong(Result, GWL_METHODDATA, cardinal(TMethod(wndProcMethod).Data));
SetWindowLong(Result, GWL_METHODCODE, cardinal(TMethod(wndProcMethod).Code));
{$ENDIF ~CPUX64}
Inc(GDSiWndHandlerCount);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiAllocateHWnd }
//Thread-safe DeallocateHwnd.
// #author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
// TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
// #since 2007-05-30
procedure DSiDeallocateHWnd(wnd: HWND);
begin
if wnd = 0 then
Exit;
DestroyWindow(wnd);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
Dec(GDSiWndHandlerCount);
if GDSiWndHandlerCount <= 0 then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiDeallocateHWnd }
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
initialization
InitializeCriticalSection(GDSiWndHandlerCritSect);
RedirectProcedure(#AllocateHWnd, #DSiAllocateHWnd);
RedirectProcedure(#DeallocateHWnd, #DSiDeallocateHWnd);
finalization
DeleteCriticalSection(GDSiWndHandlerCritSect);
end.
This unit must be included very early in the .dpr file's list of units. Clearly it cannot appear before any custom memory manager, but it should appear immediately after that. The reason being that the replacement routines must be installed before any calls to AllocateHwnd are made.
Update I have merged in the very latest version of Primož's code which he kindly sent to me.

Don't use TTimer in a thread, it will never be safe. Have the thread either:
1) use SetTimer() with a manual message loop. You don't need an HWND if you use a callback function, but you do still have to dispatch messages.
2) use CreateWaitableTimer() and then call WaitForSingleObject() in a loop until the timer is signalled.
3) use timeSetEvent(), which is a multi-threaded timer. Just be careful because its callback is called in its own thread so make sure your callback function is thread-safe, and there are restrictions to what you are allowed to call inside that thread. Best to have it set a signal that your real thread waits on an then does its work outside of the timer.

Since you have already written code that operates in a dedicated thread, I would assume you don't expect any code to run while this code waits for something. In that case you could just call Sleep either with a specific number of milliseconds, or with a small amount of milliseconds and use this in a loop to check Now or GetTickCount to see if a certain time has elapsed. Using Sleep will also keep CPU-usage down, since the operating system is signaled that you don't require the thread to keep running for that time.

Related

Why do I get a stack overflow when I call the Windows API from my Delphi program?

My form supports drag'n'drop of files from the Windows Explorer:
uses
ShellApi, System.IOUtils;
procedure TFormMain.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Self.Handle, True);
end;
procedure TFormMain.WMDropFiles(var Msg: TMessage);
var
hDrop: THandle;
FileCount, NameLen, i: Integer;
CurrFile: String;
FileSysEntries: TArray<String>;
begin
inherited;
hDrop := Msg.wParam;
try
FileCount := DragQueryFile(hDrop, $FFFFFFFF, nil, 0);
for i := 0 to FileCount - 1 do
begin
NameLen := DragQueryFile(hDrop, i, nil, 0) + 1; //+1 for NULL
SetLength(CurrFile, NameLen);
DragQueryFile(hDrop, i, PWideChar(CurrFile), NameLen);
//If I don't do this...
SetLength(CurrFile, StrLen(PWideChar(CurrFile)));
if DirectoryExists(CurrFile) then
begin
//...I get a stack overflow here!
FileSysEntries := TDirectory.GetFiles(CurrFile, '*.*', TSearchOption.soAllDirectories);
//Rest removed for clarity...
end;
end;
finally
DragFinish(hDrop);
end;
end;
Now if I don't strip the NULL (#0) character off the CurrFile string (see 2nd SetLength) I get a stack overflow when I call TDirectory.GetFiles and I'm now sure why.
Is the second SetLength (that strips #0) really necessary or should I do NameLen - 1 for the first SetLength? Or maybe something else?
I see a few issues:
you are calling DragAcceptFiles() only in the Form's OnCreate event. If the Form's HWND is ever re-created during the Form's lifetime (it can happen!), you will lose the ability to receive WM_DROPFILES messages.
You would need to call DragAcceptFiles() again with the updated HWND. You can override the Form's virtual CreateWnd() method to handle that.
Alternatively, you can override the Form's virtual CreateParams() method to enable the WS_EX_ACCEPTFILES extended window style for each HWND that is created.
your message handler is calling inherited. You don't need to do that. The default handler will not do anything with the message.
you are over-allocating memory for CurrFile. You technically DO NOT need to include the null terminator when calling SetLength(), as it will automatically allocate extra space for one (a Delphi string is implicitly null-terminated, so that PChar casts can be used with C-style APIs that expect null-terminated character pointers).
If you DO include the null terminator in the string's length, you have to explicitly shrink the strings length afterwards, which you are doing (but not as efficiently as you could be, as DragQueryFile(i) will tell you the length to use without a null terminator, so you don't have to calculate it manually with StrLen()). But, it is better to simply not over-allocate to begin with.
Apparently having that extra #0 in the string's length is causing problems for TDirectory.GetFiles() (or more likely, TPath, which TDirectory uses internally). You should file a bug report about that. But, you do need to make sure you don't leave the terminating #0 in the string's length to begin with, since filesystem path APIs don't accept it anyway.
Try this instead:
uses
ShellApi, System.IOUtils;
procedure TFormMain.CreateWnd;
begin
inherited;
DragAcceptFiles(Self.Handle, True);
end;
procedure TFormMain.WMDropFiles(var Msg: TMessage);
var
hDrop: THandle;
FileCount, NameLen, i: Integer;
CurrFile: String;
FileSysEntries: TArray<String>;
begin
hDrop := Msg.wParam;
try
FileCount := DragQueryFile(hDrop, $FFFFFFFF, nil, 0);
for i := 0 to FileCount - 1 do
begin
NameLen := DragQueryFile(hDrop, i, nil, 0);
SetLength(CurrFile, NameLen);
DragQueryFile(hDrop, i, PChar(CurrFile), NameLen + 1);
if TDirectory.Exists(CurrFile) then
begin
FileSysEntries := TDirectory.GetFiles(CurrFile, '*.*', TSearchOption.soAllDirectories);
//...
end;
end;
finally
DragFinish(hDrop);
end;
end;

Delphi 64bit DLL: OleCtrls events issues

I've converted a DLL from 32 bit to 64 bit having no problem, but when I load this DLL from a 64 bit application that occupies a large amount of memory the application crashes and closes itself when DLL is loaded.
The DLL is a simple form with a TWebBrowser on it. I use Delphi 10 Seattle.
After debugging I found a 64 bit conversion problem in the vcl unit "Vcl.OleCtrls.pas" solved in this way:
procedure TOleControl.HookControlWndProc;
var
WndHandle: HWnd;
begin
if (FOleInPlaceObject <> nil) and (WindowHandle = 0) then
begin
WndHandle := 0;
FOleInPlaceObject.GetWindow(WndHandle);
if WndHandle = 0 then raise EOleError.CreateRes(#SNoWindowHandle);
WindowHandle := WndHandle;
//DefWndProc := Pointer(GetWindowLong(WindowHandle, GWL_WNDPROC));//OLD
DefWndProc := Pointer(GetWindowLongPtr(WindowHandle, GWL_WNDPROC));
CreationControl := Self;
//SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(#InitWndProc));//OLD
SetWindowLongPtr(WindowHandle, GWL_WNDPROC, LONG_PTR(#InitWndProc));
SendMessage(WindowHandle, WM_NULL, 0, 0);
end;
end;
This solves the crash issue, but TWebBrowser events are not fired anymore and happens on 64bit only.
How can I fix TWebBrowser events firig?
Have you find similar issue or workaroud to fix events?
Thanks
I found another cast error that generate the TWebBrowser event issue.
In Emba unit "Vcl.OleCtrls.pas":
procedure TOleControl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
{$IFDEF CPUX64}
var
EventMethod: TMethod;
ParamBlock : TParamBlock;
i : Integer;
StackParams2 : array of Int64;
begin
GetEventMethod(DispID, EventMethod);
//if Integer(EventMethod.Code) < $10000 then Exit; //OLD
if Int64(EventMethod.Code) < $10000 then Exit; //NEW
ParamBlock.RegRCX := Int64(EventMethod.Data);
ParamBlock.RegRDX := Int64(Self);
if Params.cArgs > 2 then
begin
SetLength(StackParams2, Params.cArgs-2);
end;
for i := 1 to Params.cArgs do
case i of
1: ParamBlock.RegR8 := Int64(Params.rgvarg[Params.cArgs-1].unkVal);
2: ParamBlock.RegR9 := Int64(Params.rgvarg[Params.cArgs-2].unkVal);
else
StackParams2[i-3] := Int64(Params.rgvarg[Params.cArgs-i].unkVal);
end;
ParamBlock.StackDataSize := Length(StackParams2) * sizeof(Pointer);
ParamBlock.StackData := #StackParams2[0];
RawInvoke(EventMethod.Code, #ParamBlock);
end;
{$ELSE !CPUX64}
Integer cast generate an overflow, on hight memory usage situation, and the InvokeEvent procedure exit not calling the actual event. Solved with Int64 cast.
I hope Emba will integrate this fix and find similar.

MessageBoxEx stops updation of actions

I use Delphi 7 and my project has several non modal visible forms. The problem is if in one of them MessageBoxEx is called all actions of the application are not updated until MessageBoxEx’s form is closed. In my project it can broke business logic of application.
The TApplication.HandleMessage method is never called while MessageBoxEx's window is shown so it doesn’t call the DoActionIdle and Actions are not updated.
I think what I need is to catch a state of my application when it’s idle and update states of all actions.
First I implemented TApplication. OnIdle handler:
procedure TKernel.OnIdle(Sender: TObject; var Done: Boolean);
begin
{It’s only to switch off the standard updating from TApplication.Idle. It's to make the CPU usage lower while MessageBoxEx's window isn't shown }
Done := False;
end;
implementation
var
MsgHook: HHOOK;
{Here is a hook}
function GetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
var
m: TMsg;
begin
Result := CallNextHookEx(MsgHook, nCode, wParam, Longint(#Msg));
if (nCode >= 0) and (_instance <> nil) then
begin
{If there aren’t the messages in the application's message queue then the application is in idle state.}
if not PeekMessage(m, 0, 0, 0, PM_NOREMOVE) then
begin
_instance.DoActionIdle;
WaitMessage;
end;
end;
end;
initialization
MsgHook := SetWindowsHookEx(WH_GETMESSAGE, #GetMsgHook, 0, GetCurrentThreadID);
finalization
if MsgHook <> 0 then
UnhookWindowsHookEx(MsgHook);
Here is a method for updating states of all actions of the application. It’s just a modified version of TApplication.DoActionIdle:
type
TCustomFormAccess = class(TCustomForm);
procedure TKernel.DoActionIdle;
var
i: Integer;
begin
for I := 0 to Screen.CustomFormCount - 1 do
with Screen.CustomForms[i] do
if HandleAllocated and IsWindowVisible(Handle) and
IsWindowEnabled(Handle) then
TCustomFormAccess(Screen.CustomForms[i]).UpdateActions;
end;
It seems that the updating of the states happens much often than usually (I’m going to find out where is a problem using profiler).
Besides, CPU usage grows seriously when the mouse’s cursor is not over the application’s windows (about 25% on my DualCore Pentium).
What do you think about my problem and the way I try to solve it? Is it a good idea to use hooks or there is a better way to catch the application idle state? Do I rather need to use WH_CALLWNDPROCRET during setting the hook?
Why MessageBoxEx blocks TApplication.HandleMessage? Is there way to prevent this behavior? I’ve tried to call it with MB_APPLMODAL, MB_SYSTEMMODAL, MB_TASKMODAL flags but it didn’t help.
MessageBox/Ex() is a modal dialog, and as such it runs its own message loop internally since the calling thread's normal message loop is blocked. MessageBox/Ex() receives any messages that are in the calling thread's message queue, and will dispatch them to target windows normally (so things like window-based timers still work, such as TTimer), but its modal message loop has no concept of VCL-specific messages, like action upates, and will discard them. TApplication.HandleMessage() is only called by the main VCL message loop, the TApplication.ProcessMessages() method, and the TForm.ShowModal() method (this is why modal VCL Form windows do not suffer from this problem), none of which are called while MessageBox/Ex() is running (the same will be true for any OS modal dialog).
To solve your problem, you have a couple of choices:
set a thread-local message hook via SetWindowsHookEx() right before calling MessageBox/Ex(), then release the hook right after MessageBox/Ex() exits. This allows you to look at every message that MessageBox/Ex() receives and dispatch them to VCL handlers as needed. DO NOT call PeekMessage(), GetMessage() or WaitMessage() inside of a message hook!
type
TApplicationAccess = class(TApplication)
end;
function GetMsgHook(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Msg: TMsg;
begin
if (nCode >= 0) and (wParam = PM_REMOVE) then
begin
Msg := PMsg(lParam)^;
with TApplicationAccess(Application) do begin
if (not IsPreProcessMessage(Msg))
and (not IsHintMsg(Msg))
and (not IsMDIMsg(Msg))
and (not IsKeyMsg(Msg))
and (not IsDlgMsg(Msg)) then
begin
end;
end;
end;
Result := CallNextHookEx(MsgHook, nCode, wParam, lParam);
end;
function DoMessageBoxEx(...): Integer;
var
MsgHook: HHOOK;
begin
MsgHook := SetWindowsHookEx(WH_GETMESSAGE, #GetMsgHook, 0, GetCurrentThreadID);
Result := MessageBoxEx(...);
if MsgHook <> 0 then UnhookWindowsHookEx(MsgHook);
end;
move the MessageBox/Ex() call to a separate worker thread so the calling thread is free to process messages normally. If you need to wait for the result of MessageBox/Ex(), such as when prompting the user for input, then you can use MsgWaitForMultipleObjects() to wait for the thread to terminate while allowing the waiting thread to call Application.ProcessMessages() whenever there are pending messages to process.
type
TMessageBoxThread = class(TThread)
protected
procedure Execute; override;
...
public
constructor Create(...);
end;
constructor TMessageBoxThread.Create(...);
begin
inherited Create(False);
...
end;
function TMessageBoxThread.Execute;
begin
ReturnValue := MessageBoxEx(...);
end;
function DoMessageBoxEx(...): Integer;
var
Thread: TMessageBoxThread;
WaitResult: DWORD;
begin
Thread := TMessageBoxThread.Create(...);
try
repeat
WaitResult := MsgWaitForMultipleObjects(1, Thread.Handle, False, INFINITE, QS_ALLINPUT);
if WaitResult = WAIT_FAILED then RaiseLastOSError;
if WaitResult = WAIT_OBJECT_0 + 1 then Application.ProcessMessages;
until WaitResult = WAIT_OBJECT_0;
Result := Thread.ReturnVal;
finally
Thread.Free;
end;
end;

Suspend/resume processes as PsSuspend does

I hope this post is not a duplicate one. Let me explain:
I have considered the similar post How to pause / resume any external process under Windows? but with C++/Python preference and yet without an accepted answer as of the time of posting.
My Question:
I'm interested in a possible implementation in Delphi of the functionality provided by PsSuspend by Mark Russinovich of Windows Sysinternals.
Quotes:
PsSuspend lets you suspend processes on the local or a remote system,
which is desirable in cases where a process is consuming a resource
(e.g. network, CPU or disk) that you want to allow different processes
to use. Rather than kill the process that's consuming the resource,
suspending permits you to let it continue operation at some later
point in time.
Thank you.
Edit:
A partial implementation will do. Remote capability can be dropped.
You can try to use the following code. It uses the undocumented functions NtSuspendProcess and NtResumeProcess. I've tried it on Windows 7 64-bit from the 32-bit application built in Delphi 2009 and it works for me. Note that these functions are undocumented thus can be removed from future versions of Windows.
Update
The SuspendProcess and ResumeProcess wrappers from the following code are now functions and returns True if succeed, False otherwise.
type
NTSTATUS = LongInt;
TProcFunction = function(ProcHandle: THandle): NTSTATUS; stdcall;
const
STATUS_SUCCESS = $00000000;
PROCESS_SUSPEND_RESUME = $0800;
function SuspendProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtSuspendProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtSuspendProcess := GetProcAddress(LibHandle, 'NtSuspendProcess');
if #NtSuspendProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtSuspendProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
function ResumeProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtResumeProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtResumeProcess := GetProcAddress(LibHandle, 'NtResumeProcess');
if #NtResumeProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtResumeProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
There is no SuspendProcess API call in Windows. So what you need to do is:
Enumerate all the threads in the process. See RRUZ's answer for sample code.
Call SuspendThread for each of these threads.
In order to implement the resume part of the program, call ResumeThread for each thread.
There is a race condition for the "suspend all threads" implementation - what happens if the program you are trying to suspend creates one or more threads between the time that you create the snapshot and the time that you complete suspending?
You could loop, getting another snapshot and suspending any unsuspending threads, exiting only when you found none.
The undocumented function avoids this issue.
I just found the following snippets here (Author: steve10120).
I think they are valuables and I can't help posting them also as an alternative answer to my own question.
Resume Process:
function ResumeProcess(ProcessID: DWORD): Boolean;
var
Snapshot,cThr: DWORD;
ThrHandle: THandle;
Thread:TThreadEntry32;
begin
Result := False;
cThr := GetCurrentThreadId;
Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
begin
Thread.dwSize := SizeOf(TThreadEntry32);
if Thread32First(Snapshot, Thread) then
repeat
if (Thread.th32ThreadID <> cThr) and (Thread.th32OwnerProcessID = ProcessID) then
begin
ThrHandle := OpenThread(THREAD_ALL_ACCESS, false, Thread.th32ThreadID);
if ThrHandle = 0 then Exit;
ResumeThread(ThrHandle);
CloseHandle(ThrHandle);
end;
until not Thread32Next(Snapshot, Thread);
Result := CloseHandle(Snapshot);
end;
end;
Suspend Process:
function SuspendProcess(PID:DWORD):Boolean;
var
hSnap: THandle;
THR32: THREADENTRY32;
hOpen: THandle;
begin
Result := FALSE;
hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if hSnap <> INVALID_HANDLE_VALUE then
begin
THR32.dwSize := SizeOf(THR32);
Thread32First(hSnap, THR32);
repeat
if THR32.th32OwnerProcessID = PID then
begin
hOpen := OpenThread($0002, FALSE, THR32.th32ThreadID);
if hOpen <> INVALID_HANDLE_VALUE then
begin
Result := TRUE;
SuspendThread(hOpen);
CloseHandle(hOpen);
end;
end;
until Thread32Next(hSnap, THR32) = FALSE;
CloseHandle(hSnap);
end;
end;
Disclaimer:
I didn't test them at all. Please enjoy and don't forget to feedback.

How to find the name of the parent program that started us?

We want a program of ours in D7 to know if it was run via a ShellExecute command from one of our apps, or directly started by the user.
Is there a reliable way for a Delphi 7 program to determine the name of the program that ran it?
We of course could have our parent program use a command line argument or other flag, but we'd prefer the above approach.
TIA
There's no way to do what you want, I'm afraid. The application isn't told whether it's being run pro grammatically via ShellExecute (or CreateProcess), via a command line, a shortcut, or a double-click in Explorer.
Raymond Chen did an article a while back on this very topic, if I remember correctly; I'll see if I can find it and update my answer here.
Based on another answer and some code on Torry.net, I came to this function to get the parent process id. It seems to return a relevant number on Windows 7, and the windows functions it uses should be available at least since Win 2000.
uses Tlhelp32;
function GetProcessInfo(ProcessId: Cardinal; out ParentProcessId: Cardinal; out ExeFileName: string): Boolean;
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
repeat
if ProcInfo.th32ProcessID = ProcessId then
begin
ExeFileName := string(ProcInfo.szExeFile);
ParentProcessId := ProcInfo.th32ParentProcessID;
Result := True;
Exit;
end;
until not Process32Next(hSnapShot, ProcInfo);
finally
CloseHandle(hSnapShot);
end;
Result := False;
end;
procedure Test;
var
ProcessId, ParentProcessId, Dummy: Cardinal;
FileName: string;
begin
ProcessId := GetCurrentProcessId();
// Get info for current process
if GetProcessInfo(ProcessId, ParentProcessId, FileName) then
// Get info for parent process
if GetProcessInfo(ParentProcessId, Dummy, FileName) then
// Show it.
ShowMessage(IntToStr(ParentProcessId) + FileName);
end;
A word of caution! The parent process may no longer exist. Even worse, it's ID may have been recycled, causing this function to give you a different process than you asked for.
The simple answer is "No".
A more complex answer is "Not as easily as simply passing a command line param would be".
:)
What you need to do is identify the parent process of your process. Obtaining this is possible but not straightforward. Details of how to go about it can be obtained in this CodeProject article.
The biggest problem is that there is not strict hierarchical relationship between processes in Windows and PID (Process ID's) may be re-used. The PID you identify as your "parent" may not be your parent at all. If the parent process has subsequently terminated then it's PID may be re-used which could lead to some seemingly perplexing results ("My process was started by calc.exe? How is that possible?").
Trying to find bullet, water and idiot proof mechanisms to protect against the possible ways such a process might fail will be significantly more effort than simply devising and implementing a command line based convention between your launcher applications and the launchee by which the latter may identify the former.
A command line parameter is one such option but could be "spoofed" (if someone figures out what you are passing on the command line and for some reason could derive some value or benefit from mimicking this themselves).
Depending on how reliable and tamper proof you need the mechanism to be, this could still be enough however.
I've found getpids which does it using NtQueryInformationProcess to not only to obtain the parent process ID but also compare the process creation times - if the reported parent process was created after the child it means the reported parent ID has already been recycled.
Here is my Delphi unit I wrote to test it:
unit ProcInfo;
interface
uses
Windows, SysUtils;
function GetParentProcessId(ProcessID: DWORD; out ProcessImageFileName: string): DWORD; overload;
implementation
uses
PsApi;
var
hNtDll: THandle;
NtQueryInformationProcess: function(ProcessHandle: THandle; ProcessInformationClass: DWORD;
ProcessInformation: Pointer; ProcessInformationLength: ULONG; ReturnLength: PULONG): DWORD; stdcall;
const
UnicodeStringBufferLength = 1025;
type
PPEB = Pointer; // PEB from winternl.h not needed here
PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;
PROCESS_BASIC_INFORMATION = record
Reserved1: Pointer; // exit status
PebBaseAddress: PPEB;
Reserved2: array[0..1] of Pointer; // affinity mask, base priority
UniqueProcessId: ULONG_PTR;
Reserved3: Pointer; // parent process ID
end;
PProcessBasicInformation = ^TProcessBasicInformation;
TProcessBasicInformation = PROCESS_BASIC_INFORMATION;
PKernelUserTimes = ^TKernelUserTimes;
TKernelUserTimes = record
CreateTime: LONGLONG;
ExitTime: LONGLONG;
KernelTime: LONGLONG;
UserTime: LONGLONG;
end;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
PBuffer: PChar;
Buffer: array[0..UnicodeStringBufferLength - 1] of Char;
end;
PUnicodeString = ^TUnicodeString;
TUnicodeString = UNICODE_STRING;
function GetProcessCreateTime(hProcess: THandle): LONGLONG;
var
ProcessTimes: TKernelUserTimes;
begin
Result := 0;
FillChar(ProcessTimes, SizeOf(ProcessTimes), 0);
if NtQueryInformationProcess(hProcess, 4, #ProcessTimes, SizeOf(ProcessTimes), nil) <> 0 then
Exit;
Result := ProcessTimes.CreateTime;
end;
function GetProcessParentId(hProcess: THandle): DWORD;
var
ProcessInfo: TProcessBasicInformation;
begin
Result := 0;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if NtQueryInformationProcess(hProcess, 0, #ProcessInfo, SizeOf(ProcessInfo), nil) <> 0 then
Exit;
Result := DWORD(ProcessInfo.Reserved3);
end;
function GetProcessImageFileName(hProcess: THandle): string;
var
ImageFileName: TUnicodeString;
begin
Result := '';
FillChar(ImageFileName, SizeOf(ImageFileName), 0);
ImageFileName.Length := 0;
ImageFileName.MaximumLength := UnicodeStringBufferLength * SizeOf(Char);
ImageFileName.PBuffer := #ImageFileName.Buffer[0];
if NtQueryInformationProcess(hProcess, 27, #ImageFileName, SizeOf(ImageFileName), nil) <> 0 then
Exit;
SetString(Result, ImageFileName.PBuffer, ImageFileName.Length);
end;
function GetParentProcessId(ProcessId: DWORD; out ProcessImageFileName: string): DWORD;
var
hProcess, hParentProcess: THandle;
ProcessCreated, ParentCreated: LONGLONG;
begin
Result := 0;
ProcessImageFileName := '';
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess = 0 then
RaiseLastOSError;
try
Result := GetProcessParentId(hProcess);
if Result = 0 then
Exit;
ProcessCreated := GetProcessCreateTime(hProcess);
finally
CloseHandle(hProcess);
end;
hParentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, Result);
if hParentProcess = 0 then
RaiseLastOSError;
try
ParentCreated := GetProcessCreateTime(hParentProcess);
if ParentCreated > ProcessCreated then
begin
Result := 0;
Exit;
end;
ProcessImageFileName := GetProcessImageFileName(hParentProcess);
finally
CloseHandle(hParentProcess);
end;
end;
initialization
hNtDll := GetModuleHandle('ntdll.dll');
if hNtDll <> 0 then
NTQueryInformationProcess := GetProcAddress(hNtDll, 'NtQueryInformationProcess');
end.
When I run the code from the IDE, I get the following results:
parent ID: 5140, parent image file name:
"\Device\HarddiskVolume1\Program Files\Embarcadero\RAD
Studio\8.0\bin\bds.exe"
so you may need to find a way to translate that into a "normal" path, e.g. "C:\Program Files\Embarcadero\RAD Studio\8.0\bin\bds.exe".

Resources