We have a Delphi application which shows dialogs using WinAPI in separate (not UI) thread. It works fine. Now we want to apply VCL styles to this application. But style correctly applies only to forms in UI thread, not for dialog in other thread. Even if I call TStyleManager.SetStyle before showing dialog in other thread. If I call TStyleManager.SetStyle and DialogBoxParamW in UI thread, style is successfully applied. Is there any workaroud to enforce a VCL style to dialog created in other thread?
Simple example:
procedure ApplyStyle;
begin
TStyleManager.SetStyle('Obsidian');
end;
function DialogProc(Dialog: HWnd; Msg: DWord; WParam: DWord;
LParam: integer): LongBool; stdcall;
begin
end;
procedure ShowDialog;
begin
DialogBoxParamW(hInstance, PChar('CUSTOM_DIALOG'), 0, #DialogProc, 0);
if GetLastError <> 0 then
ShowMessage(SysErrorMessage(GetLastError));
end;
type
TDialogThread = class(TThread)
public
procedure Execute; override;
end;
procedure TDialogThread.Execute;
begin
inherited;
ApplyStyle;
ShowDialog;
end;
// same thread
procedure TForm4.Button2Click(Sender: TObject);
begin
ApplyStyle;
ShowDialog;
end;
// other thread
procedure TForm4.Button3Click(Sender: TObject);
var
t: TDialogThread;
begin
t := TDialogThread.Create(True);
t.FreeOnTerminate := false;
t.Start;
end;
Related
I'm using Delphi XE7 on Windows 10.
I have been using the following code for a long time, and just read the documentation on SetTimer(). To state it simply, I am setting timers from non-UI threads, but Microsoft's documentation says they should only be set on the UI thread. Extensive tests show my code works fine, but I can't trust my system to behave the same as other systems, or the Microsoft documentation to be 100% accurate. Can anyone verify whether this code is OK or not OK?
The Delphi code will not deadlock, it pretty much just calls SetTimer() (I am aware there is a race condition setting TTimer.FEnabled).
The MSDN documentation says:
hWnd
Type: HWND
A handle to the window to be associated with the timer. This window must be owned by the calling thread.
What I'm trying to accomplish is worker threads doing stuff, and when appropriate, they notify the main thread that elements of the UI must be updated, and the main thread updates the UI. I know how to use TThread.Synchronize(), but deadlocks can happen in certain cases. I can use PostMessage() from my worker threads and handle the message in the UI thread.
Is there any other way in Delphi to notify and update the UI thread?
unit FormTestSync;
interface
uses SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
timer_update: TTimer;
Label1: TLabel;
procedure timer_updateTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
m_thread: TypeThreadTest;
m_value: integer;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while (not terminated) do begin
//do work...
form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
timer_update.enabled := false;
timer_update.interval := 1;
m_thread := TypeThreadTest.Create();
end;
procedure TForm1.Notify(value: integer);
begin
//run on worker thread
//Race conditions here, I left out the synchronization for simplicity
m_value := value;
timer_update.Enabled := true;
end;
procedure TForm1.timer_updateTimer(Sender: TObject);
begin
timer_update.Enabled := false;
label1.Caption := IntToStr(m_value);
end;
end.
The TTimer is being constructed in the main UI thread, when the TForm streams in its DFM resource. The TTimer's constructor creates an internal HWND for the timer to receive WM_TIMER messages with. That HWND is thus owned by the main UI thread.
TForm.Notify() is setting the timer's Enabled property to true, which will call SetTimer(). Notify() is being called in the context of the worker thread, not the main UI thread. This SHOULD NOT work, as stated in SetTimer()'s documentation. Only the main UI thread should be able to start the timer running, since the main UI thread owns the timer's HWND.
TTimer.UpdateTimer(), which is called internally by the setters of the timer's Enabled, Interval and OnTimer properties, will raise an EOutOfResources exception if SetTimer() fails. So, calling form1.Notify() in TypeThreadTest.Execute() SHOULD NOT work. The only way SetTimer() would not be called in that situation is if either:
Interval is 0
Enabled is false
OnTimer is unassigned
Otherwise, your worker thread SHOULD be crashing.
As you have noted, your worker thread can alternatively use TThread.Synchronize() (or TThread.Queue()), or PostMessage() (or SendMessage()), when it wants to notify the main UI thread to do something. These are viable and preferred solutions. Personally, I would opt for TThread.Queue(), eg:
unit FormTestSync;
interface
uses
SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
m_thread: TypeThreadTest;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while not Terminated do begin
//do work...
Form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_thread := TypeThreadTest.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
end;
procedure TForm1.Notify(value: integer);
begin
//runs on worker thread
TThread.Queue(nil,
procedure
begin
//runs on main UI thread
Label1.Caption := IntToStr(value);
end
);
end;
end.
If you want to use TTimer instead for this work, what you could do is simply enable the timer in the main UI thread and leave it enabled, and just synchronize access to the data that the timer accesses periodically. That would be perfectly safe, eg:
unit FormTestSync;
interface
uses
SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls, SyncObjs;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
timer_update: TTimer;
Label1: TLabel;
procedure timer_updateTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
m_thread: TypeThreadTest;
m_value: integer;
m_updated: boolean;
m_lock: TCriticalSection;
private
procedure UpdateValue(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while not Terminated do begin
//do work...
Form1.UpdateValue(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_lock := TCriticalSection.Create;
timer_update.Interval := 100;
timer_update.Enabled := true;
m_thread := TypeThreadTest.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
m_lock.Free;
end;
procedure TForm1.UpdateValue(value: integer);
begin
//runs on worker thread
m_lock.Enter;
try
m_value := value;
m_updated := true;
finally
m_lock.Leave;
end;
end;
procedure TForm1.timer_updateTimer(Sender: TObject);
begin
//runs on main UI thread
if m_updated then
begin
m_lock.Enter;
try
Label1.Caption := IntToStr(m_value);
m_updated := false;
finally
m_lock.Leave;
end;
end;
end;
end.
UPDATE:
I did a quick test. When SetTimer() is called with a non-NULL HWND that is owned by another thread, sure enough on Windows XP, 7 and 10 (I did not test Vista or 8), SetTimer() succeeds, and the WM_TIMER/TimerProc is called in the context of the thread that owns the HWND, not the thread that is calling SetTimer(). This is NOT documented behavior, so do not rely on it! SetTimer()'s documentation clearly says the HWND "must be owned by the calling thread", as you stated in your question.
In any case, TTimer is a VCL component, and the VCL is inherently not thread-safe in general. Even though your TTimer code "works", it is not a good idea to access UI components outside of the main UI thread anyway, that is just bad code design. Stick with an alternative solution that is known to be thread-safe.
Edit: Thread safety is extremely difficult. I inserted AllocateHwnd() to replace self.handle according to mghie's comment.
Here is how I am planning to implement the UI notification + update. It's not any more complicated than the TTimer approach, and it doesn't have any thread safety issues that I know of. Different messages can be defined for different items that need to be updated.
If update notifications could be sent very rapidly, a variation on this theme is necessary to reduce the number of PostMessage calls. Also modifications are necessary if value cannot fit into WParam.
unit FormTestSync;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms, StdCtrls,
Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
const
WM_UPDATE = WM_USER + 1;
procedure OnMessage_Update(var message: TMessage);
private
m_thread: TypeThreadTest;
m_hwndAlwaysThere: HWND;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while (not terminated) do begin
//do work...
form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_hwndAlwaysThere := AllocateHWnd(self.OnMessage_Update);
m_thread := TypeThreadTest.Create();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
DeallocateHWnd(m_hwndAlwaysThere);
end;
procedure TForm1.Notify(value: integer);
begin
//run on worker thread
PostMessage(m_hwndAlwaysThere, WM_UPDATE, value, 0);
end;
procedure TForm1.OnMessage_Update(var message: TMessage);
begin
//run on UI thread
label1.Caption := IntToStr(message.WParam);
end;
end.
I'm using the TThread.DoTerminate method to notify to the main thread which the TThread has terminated. but as soon try to change the properties of some controls (buttons) from inside of the DoTerminate both controls just disappear of the form.
Also when I close the Form I'm getting this message
Project ProjectTest.exe raised exception class EOSError with message
'System Error. Code: 1400. Invalid window handle'.
This is a sample application to reproduce the issue.
type
TFooThread = class;
TFormSample = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FooThread : TFooThread;
procedure ThreadIsDone;
public
end;
TFooThread = class(TThread)
private
FForm : TFormSample;
protected
procedure DoTerminate; override;
public
procedure Execute; override;
constructor Create(AForm : TFormSample); reintroduce;
destructor Destroy; override;
end;
var
FormSample: TFormSample;
implementation
{$R *.dfm}
{ TFooThread }
constructor TFooThread.Create(AForm: TFormSample);
begin
inherited Create(False);
FreeOnTerminate := False;
FForm := AForm;
end;
destructor TFooThread.Destroy;
begin
inherited;
end;
procedure TFooThread.DoTerminate;
begin
FForm.ThreadIsDone;
inherited;
end;
procedure TFooThread.Execute;
var
i : Integer;
begin
for i := 1 to 100 do
begin
Synchronize(
procedure
begin
FForm.ProgressBar1.Position := i;
end
);
Sleep(50);
end;
Terminate();
end;
{ TFormSample }
procedure TFormSample.Button1Click(Sender: TObject);
begin
FooThread := TFooThread.Create(Self);
TButton(Sender).Enabled := false;
end;
procedure TFormSample.FormCreate(Sender: TObject);
begin
FooThread := nil;
Button3.Visible := False;
end;
procedure TFormSample.FormDestroy(Sender: TObject);
begin
if (FooThread<>nil) then
begin
if not FooThread.Terminated then
FooThread.WaitFor;
FooThread.Free;
end;
end;
procedure TFormSample.ThreadIsDone;
begin
//this code is executed but the controls are not updated
//both buttons just disappear from the form !!!!
//Also if I remove these lines, no error is raised.
Button2.Visible := False;
Button3.Visible := True;
end;
end.
The question is : How I can update the properties of some VCL control as soon the TThread is finished?
It should be fine to update controls inside DoTerminate (as you are).
DoTerminate runs in the context of the thread. Therefore it is not safe to update controls from that method. The base implementation synchronises a call to the OnTerminate event.
So OnTerminate is already synchronised. And it will be safe to update controls from an OnTerminate event handler.
However, I would be more inclined to not have code inside the thread class calling the form because this creates a circular dependency. Rather have the form assign a handler for the OnTerminateevent. This way code that controls the form will be in the form class. You can do the same with the control updates to indicate thread progress.
FooThread := TFooThread.Create(...);
//WARNING: If you need to do **any**
//initialisation after creating a
//thread, it's better to create it
//in a Suspended state.
FooThread.OnTerminate := ThreadIsDone;
//Of course you'll have to change the signature of ThreadIsDone accordingly.
FooThread.OnProgress := ThreadProgress;
//You'd have to define a suitable callback event on the thread.
//Finally, if the thread started in a suspended state, resume it.
FooThread.Start;
Avoiding circular dependencies is a little more work, but greatly simplifies an application.
David mentions that you can create your thread in a running state. To do so safely you must:
Pass all necessary initialisation information into the constructor.
And inside the constructor perform all initialisation before calling the inherited constructor.
Also you have a mistake in your Execute method:
procedure TFooThread.Execute;
var
i : Integer;
begin
...
Terminate(); //This is pointless.
//All it does is set Terminated := True;
end;
The thread terminates when it exits. All the call to Terminate does is set an internal flag to indicate the thread should terminate. You'd normally write your Execute method as follows:
begin
while not Terminated do
begin
...
end;
end;
Then your form might have a button which calls: FooThread.Terminate();
This will cause your while loop to exit at the end of the current iteration. This allows the thread to exit "gracefully".
Hi I'm doing a code MessageDlgPos running five threads at the same time, the code is this:
type
TMyThread = class(TThread)
protected
procedure Execute; override;
public
text: string;
property ReturnValue;
end;
procedure TMyThread.Execute;
begin
if Terminated then
Exit;
MessageDlgPos(text, mtInformation, [mbOk], 0, 100, 200);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
LThread: TMyThread;
i: Integer;
begin
For i := 1 to 5 do
begin
LThread := TMyThread(Sender);
try
LThread.text := 'hi';
LThread.FreeOnTerminate := True;
except
LThread.Free;
raise;
end;
LThread.Resume;
end;
end;
The problem is that Delphi XE always returns the following error and does not execute anything:
First chance exception at $ 7524B727. Exception class EAccessViolation with message 'Access violation at address 00D0B9AB. Write of address 8CC38309 '. Process tester.exe (6300)
How do I fix this problem?
As David Heffernan pointed out, MessageDlgPos() cannot safely be called outside of the main UI thread, and you are not managing the thread correctly. Your code needs to look more like this instead:
type
TMyThread = class(TThread)
protected
procedure Execute; override;
public
text: string;
property ReturnValue;
end;
procedure TMyThread.Execute;
begin
// no need to check Terminated here, TThread already
// does that before calling Execute()...
TThread.Synchronize(nil,
procedure
begin
MessageDlgPos(text, mtInformation, [mbOk], 0, 100, 200);
end
);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
LThread: TMyThread;
i: Integer;
begin
For i := 1 to 5 do
begin
LThread := TMyThread.Create(True);
LThread.text := 'hi';
LThread.FreeOnTerminate := True;
LThread.Start;
end;
end;
I would suggest a slightly different variation:
type
TMyThread = class(TThread)
private
fText: string;
protected
procedure Execute; override;
public
constructor Create(const aText: string); reintroduce;
property ReturnValue;
end;
constructor TMyThread.Create(const aText: string);
begin
inherited Create(False);
FreeOnTerminate := True;
fText := aText;
end;
procedure TMyThread.Execute;
begin
// no need to check Terminated here, TThread already
// does that before calling Execute()...
TThread.Synchronize(nil,
procedure
begin
MessageDlgPos(fText, mtInformation, [mbOk], 0, 100, 200);
end
);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
i: Integer;
begin
For i := 1 to 5 do
begin
TMyThread.Create('hi');
end;
end;
But either way, if you don't like using TThread.Synchronize() to delegate to the main thread (thus only displaying 1 dialog at a time) then you cannot use MessageDlgPos() at all, since it is only safe to call in the main UI thread. You can use Windows.MessageBox() instead, which can be safely called in a worker thread without delegation (but then you lose the ability to specify its screen position, unless you access its HWND directly by using a thread-local hook via SetWindowsHookEx() to intercept the dialog's creation and discover its HWND):
procedure TMyThread.Execute;
begin
Windows.MessageBox(0, PChar(fText), PChar(Application.Title), MB_OK or MB_ICONINFORMATION);
);
end;
There are many problems. The biggest one is here:
LThread := TMyThread(Sender);
Sender is a button. Casting to a thread is simply wrong and the cause of your exception. Casting a button to a thread doesn't make it so. It's still a button.
You likely mean to create a thread instead.
LThread := TMyThread.Create(True);
You cannot show VCL UI outside the main thread. The call to MessageDlgPos breaks that rule. If you do need to show UI at that point, you'll need to use TThread.Synchronize to have the code execute in the main thread.
Your exception handler makes no sense to me. I think you should remove it.
Resume is deprecated. Use Start instead.
I am designing a thread pool with following features.
New thread should be spawned only when all other threads are running.
Maximum number of thread should be configurable.
When a thread is waiting, it should be able to handle new requests.
Each IO operation should call a callback on completion
Thread should have a way to manage request its serving and IO callbacks
Here is the code:
unit ThreadUtilities;
interface
uses
Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
fis32MaxThreadCount : Integer;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
procedure SetMaxThreadCount(const pis32MaxThreadCount : Integer);
function GetMaxThreadCount : Integer;
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
property MaxThreadCount : Integer read GetMaxThreadCount write SetMaxThreadCount;
end;
implementation
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue = 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, Cardinal(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
Changed the code as suggested by J... also added critical sections but the problem i am facing now is that when i am trying call multiple task only one thread is being used, Lets say if i added 5 threads in the pool then only one thread is being used which is thread 1. Please check my client code as well in the below section.
procedure TSimpleThread.Execute;
begin
// if Assigned(FExecuteEvent) then
// FExecuteEvent(Self);
while not self.Terminated do begin
try
// FGoEvent.WaitFor(INFINITE);
// FGoEvent.ResetEvent;
EnterCriticalSection(csCriticalSection);
if self.Terminated then break;
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
finally
LeaveCriticalSection(csCriticalSection);
// HandleException;
end;
end;
end;
In the Add method, how can I check if there is any thread which is not busy, if it is not busy then reuse it else create a new thread and add it in ThreadPool list?
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
// if FThreads.Count < MaxThreadCount then
// begin
// FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
// end;
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count = 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
function TThreadPool.GetMaxThreadCount: Integer;
begin
Result := fis32MaxThreadCount;
end;
procedure TThreadPool.SetMaxThreadCount(const pis32MaxThreadCount: Integer);
begin
fis32MaxThreadCount := pis32MaxThreadCount;
end;
end.
Client Code :
This the client i created to log the data in text file :
unit ThreadClient;
interface
uses Windows, SysUtils, Classes, ThreadUtilities;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
procedure SetMaxThreadCount(const pis32MaxThreadCnt : Integer);
end;
implementation
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
//-- Pool of one thread to handle queue of logs
FThreadPool := TThreadPool.Create(HandleLogRequest, 5);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
los32Idx : Integer;
begin
Request := Data;
try
for los32Idx := 0 to 100 do
begin
LogToFile(FFileName, IntToStr( AThread.ThreadID) + Request^.LogText);
end;
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
procedure TThreadFileLog.SetMaxThreadCount(const pis32MaxThreadCnt: Integer);
begin
FThreadPool.MaxThreadCount := pis32MaxThreadCnt;
end;
end.
This is the form application where i added three buttons, each button click will write some value to the file with thread id and text msg. But the problem is thread id is always same
unit ThreadPool;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadClient;
type
TForm5 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
fiFileLog : TThreadFileLog;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.Button1Click(Sender: TObject);
begin
fiFileLog.Log('Button one click');
end;
procedure TForm5.Button2Click(Sender: TObject);
begin
fiFileLog.Log('Button two click');
end;
procedure TForm5.Button3Click(Sender: TObject);
begin
fiFileLog.Log('Button three click');
end;
procedure TForm5.Edit1Change(Sender: TObject);
begin
fiFileLog.SetMaxThreadCount(StrToInt(Edit1.Text));
end;
procedure TForm5.FormCreate(Sender: TObject);
begin
fiFileLog := TThreadFileLog.Create('C:/test123.txt');
end;
end.
First, and probably most strongly advisable, you might consider using a library like OmniThread to implement a threadpool. The hard work is done for you and you will likely end up making a substandard and buggy product with a roll-your-own solution. Unless you have special requirements this is probably the fastest and easiest solution.
That said, if you want to try to do this...
What you might consider is to just make all of the threads in your pool at startup rather than on-demand. If the server is going to busy at any point then it will eventually end up with a pool of MaxThreadCount soon enough anyway.
In any case, if you want to keep a pool of threads alive and available for work then they would need to follow a slightly different model than what you have written.
Consider:
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
Here when you run your thread it will execute this callback and then terminate. This doesn't seem to be what you want. What you seem to want is to keep the thread alive but waiting for its next work package. I use a base thread class (for pools) with an execute method that looks something like this (this is somewhat simplified):
procedure TMyCustomThread.Execute;
begin
while not self.Terminated do begin
try
FGoEvent.WaitFor(INFINITE);
FGoEvent.ResetEvent;
if self.Terminated then break;
MainExecute;
except
HandleException;
end;
end;
end;
Here FGoEvent is a TEvent. The implementing class defines what the work package looks like in the abstract MainExecute method, but whatever it is the thread will perform its work and then return to waiting for the FGoEvent to signal that it has new work to do.
In your case, you need to keep track of which threads are waiting and which are working. You will probably want a manager class of some sort to keep track of these thread objects. Assigning something simple like a threadID to each one seems sensible. For each thread, just before launching it, make a record that it is currently busy. At the very end of your work package you can then post a message back to the manager class telling it that the work is done (and that it can flag the thread as available for work).
When you add work to the queue you can first check for available threads to run the work (or create a new one if you wish to follow the model you outlined). If there are threads then launch the task, if there are not then push the work onto the work queue. When worker threads report complete the manager can check the queue for outstanding work. If there is work it can immediately re-deploy the thread. If there isn't work it can flag the thread as available for work (here you might use a second queue for available workers).
A full implementation is too complex to document in a single answer here - this aims just to rough out some general ideas.
Good afternoon :-),
I have one Frame. This Frame I dynamically created by Main Form.
Main form:
Interface := TInterface.Create(self);
with handlingInterface do begin
Parent := Form1;
Left := 0; Top := 35;
Width := 570; Height := 250;
end;
In Frame I have a Thread. I call this Thread from Frame. Why I can synchronize Thread with Frame? There isn't any:
var
Form1: TForm1;
I call Thread inside Frame and I want to change Position of ProgressBar in Frame. I don't know, why I can in Synchronize method of Thread access the ProgressBar.
If would be Thread and ProgressBar in Form - Synchronize access is Form1.ProgressBar ...
But I have Thread and ProgressBar in Frame.
If the only thing you're trying to do is update the progress bar from the thread, there is a lighter weight option. I would consider using PostMessage instead. You don't want your thread to know too much about the details of the frame anyway.
When you create the thread, give it the handle of your frame so it knows where to post the message. Have the frame listen for the Windows message, which includes the progress position, and update the progress bar.
Here is a very simple example that increments the progress bar from 0 to 100 with a short sleep between each increment:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
const
WM_PROGRESS_MESSAGE = WM_USER + 99;
type
TProgressThread = class(TThread)
private
FWindowHandle: HWND;
protected
procedure Execute; override;
public
property WindowHandle: HWND read FWindowHandle write FWindowHandle;
end;
TFrame2 = class(TFrame)
ProgressBar1: TProgressBar;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure OnProgressMessage(var Msg: TMessage); message WM_PROGRESS_MESSAGE;
public
end;
implementation
{$R *.dfm}
{ TFrame2 }
procedure TFrame2.Button1Click(Sender: TObject);
var
lThread: TProgressThread;
begin
lThread := TProgressThread.Create(True);
lThread.FreeOnTerminate := True;
lThread.WindowHandle := Self.Handle;
lThread.Start;
end;
procedure TFrame2.OnProgressMessage(var Msg: TMessage);
begin
ProgressBar1.Position := Msg.WParam;
end;
{ TProgressThread }
procedure TProgressThread.Execute;
var
lProgressCount: Integer;
begin
inherited;
for lProgressCount := 0 to 100 do
begin
PostMessage(FWindowHandle, WM_PROGRESS_MESSAGE, lProgressCount, 0);
Sleep(15);
end;
end;
end.
You can give a reference to your progress bar to the thread.
Sample thread class.
unit Unit6;
interface
uses
Classes, ComCtrls;
type
TProgressBarThread = class(TThread)
private
{ Private declarations }
FProgressBar: TProgressBar;
procedure MoveProgress;
protected
procedure Execute; override;
public
procedure SetProgressBar(ProgressBar: TProgressBar);
end;
implementation
{ ProgressBarThread }
procedure TProgressBarThread.Execute;
begin
{ Place thread code here }
Synchronize(MoveProgress);
end;
procedure TProgressBarThread.MoveProgress;
begin
FProgressBar.StepIt;
end;
procedure TProgressBarThread.SetProgressBar(ProgressBar: TProgressBar);
begin
FProgressBar := ProgressBar;
end;
end.
Use like this
var
PBT: TProgressBarThread;
begin
PBT := TProgressBarThread.Create(True);
PBT.FreeOnTerminate := True;
PBT.SetProgressBar(ProgressBar1);
PBT.Start;
// PBT.Resume;
end;