Delphi multi-threading file write: I/O error 32 - multithreading

I created a class for writing thread-safe log in a text file using CriticalSection.
I am not an expert of CriticalSection and multi-threading programming (...and Delphi), I'm definitely doing something wrong...
unit ErrorLog;
interface
uses
Winapi.Windows, System.SysUtils;
type
TErrorLog = class
private
FTextFile : TextFile;
FLock : TRTLCriticalSection;
public
constructor Create(const aLogFilename:string);
destructor Destroy; override;
procedure Write(const ErrorText: string);
end;
implementation
constructor TErrorLog.Create(const aLogFilename:string);
begin
inherited Create;
InitializeCriticalSection(FLock);
AssignFile(FTextFile, aLogFilename);
if FileExists(aLogFilename) then
Append(FTextFile)
else
Rewrite(FTextFile);
end;
destructor TErrorLog.Destroy;
const
fmTextOpenWrite = 55218;
begin
EnterCriticalSection(FLock);
try
if TTextRec(FTextFile).Mode <> fmTextOpenWrite then
CloseFile(FTextFile);
inherited Destroy;
finally
LeaveCriticalSection(FLock);
DeleteCriticalSection(FLock);
end;
end;
procedure TErrorLog.Write(const ErrorText: string);
begin
EnterCriticalSection(FLock);
try
WriteLn(FTextFile, ErrorText);
finally
LeaveCriticalSection(FLock);
end;
end;
end.
to test the class I created a form with a timer set to 100 milliseconds:
procedure TForm1.Timer1Timer(Sender: TObject);
var
I : integer;
aErrorLog : TErrorLog;
begin
aErrorLog := nil;
for I := 0 to 1000 do begin
try
aErrorLog := TErrorLog.Create(FormatDateTime('ddmmyyyy', Now) + '.txt');
aErrorLog.Write('new line');
finally
if Assigned(aErrorLog) then FreeAndNil(aErrorLog);
end;
end;
end;
the logs are written, but occasionally raise I/O Error 32 exception on CloseFile(FTextFile) (probably because in use in another thread)
where am I doing wrong?
UPDATE:
after reading all the comments and the answers I have totally changed approach. I share my solution.
ThreadUtilities.pas
(* Implemented for Delphi3000.com Articles, 11/01/2004
Chris Baldwin
Director & Chief Architect
Alive Technology Limited
http://www.alivetechnology.com
*)
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;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
end;
implementation
{ TThreadQueue }
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;
(* Pop will return false if the queue is completed *)
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, ULONG_PTR(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;
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
while FThreads.Count < MaxThreads do
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;
end.
ThreadFileLog.pas
(* From: http://delphi.cjcsoft.net/viewthread.php?tid=45763 *)
unit ThreadFileLog;
interface
uses Windows, ThreadUtilities, System.Classes;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText : String;
FileName : String;
end;
TThreadFileLog = class(TObject)
private
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create();
destructor Destroy; override;
procedure Log(const FileName, LogText: string);
end;
implementation
uses
System.SysUtils;
(* 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, LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create();
begin
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
begin
Request := Data;
try
LogToFile(Request^.FileName, Request^.LogText);
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const FileName, LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
Request^.FileName := FileName;
FThreadPool.Add(Request);
end;
end.
Basic form example
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
Vcl.StdCtrls, ThreadFileLog;
type
TForm1 = class(TForm)
BtnStart: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
private
FThreadFileLog : TThreadFileLog;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.BtnStartClick(Sender: TObject);
var
I : integer;
aNow : TDateTime;
begin
aNow := Now;
for I := 0 to 500 do
FThreadFileLog.Log(
FormatDateTime('ddmmyyyyhhnn', aNow) + '.txt',
FormatDateTime('dd-mm-yyyy hh:nn:ss.zzz', aNow) + ': I: ' + I.ToString
);
ShowMessage('logs are performed!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FThreadFileLog := TThreadFileLog.Create();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FThreadFileLog.Free;
ReportMemoryLeaksOnShutdown := true;
end;
end.
Output log:
30-11-2014 14.01.13.252: I: 0
30-11-2014 14.01.13.252: I: 1
30-11-2014 14.01.13.252: I: 2
30-11-2014 14.01.13.252: I: 3
30-11-2014 14.01.13.252: I: 4
30-11-2014 14.01.13.252: I: 5
30-11-2014 14.01.13.252: I: 6
30-11-2014 14.01.13.252: I: 7
30-11-2014 14.01.13.252: I: 8
30-11-2014 14.01.13.252: I: 9
...
30-11-2014 14.01.13.252: I: 500

Instead of checking TTextRec(FTextFile).Mode <> fmTextOpenWrite you should check whether your file is closed or not, and if it is not closed then you close it.
Try replacing the mentioned check with this code:
if TTextRec(FTextFile).Mode <> fmClosed then
CloseFile(FTextFile);
Edited:
This has nothing to do with antivirus locking the file. This is just a simple mistake in the destructor.
File is already opened in open write mode, original code is closing the file only when it is not in open write mode - so it is never closing the file.
Hope this explains where the mistake has happened.
As for the overall design of the logger's class. This was not the question, questions was simple, and I've provided a simple and working solution.
I think that if Simone would want us to teach him how to design logger class then he would ask for it.

If you want an error log class, where multiple threads can write to a log file, it is correct to protect the writing method with a critical section.
Now, since you will only instantiate one of those error logging objects in your application, there is no need to protect the destructor method with a critical section.
The location of your error log file should reside in the application data folder.
The I/O error 32 is: The process cannot access the file because it is being used by another process.
The reason for this sharing violation could be in your application or an external application.
Writing inside the application directory could trigger some antivirus protection for example. Or your application is holding the file open in several places with different file modes.
Your test is flawed in multiple ways:
Instantiate the error log class once at application start, and destroy it when the application closes.
Write to your error log from different threads, not from multiple iterations within a timer event.
A timer event should only execute a program sequence for a short duration.
A try / finally sequence is structured like this:
anObject := TObject.Create;
try
// Do something with anObject
finally
anObject.Free;
end;

Related

Function result from threading always delayed?

I want to make an integer result from a thread. It's just a simple calculation.
My problem, I can not have an "instant" result from it. I have execute more than once, then I got the correct result.
Here the unit form :
unit Unit1;
interface
uses
System.SysUtils,
System.Classes,
Vcl.Controls, Vcl.Forms, Vcl.StdCtrls;
type
TForm1 = class(TForm)
btn1: TButton;
mmo1: TMemo;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure CaclDone(Sender: TObject);
procedure BeginCal(calA, calB: Integer);
function StartCalc(const calA, calB: Integer): Int64;
end;
var
nOut: Int64;
Form1: TForm1;
implementation
{$R *.dfm}
uses uCalculationThread;
procedure TForm1.BeginCal(calA: Integer; calB: Integer);
var
P: TCalc;
begin
nOut := 0;
P := TCalc.Create;
P.numa := calA;
P.numb := calB;
P.OnTerminate := CaclDone;
P.Start;
end;
procedure TForm1.CaclDone(Sender: TObject);
var
P: TCalc;
begin
P := TCalc(Sender);
nOut := P.iOut;
mmo1.Lines.Add('on thread finished : ' + IntToStr(nOut)); // < here is instant result
end;
function TForm1.StartCalc(const calA, calB: Integer): Int64;
begin
BeginCal(calA, calB);
Result := nOut;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
i: Int64;
begin
i := StartCalc(10, 20);
mmo1.Lines.Add('on function call : ' + IntToStr(i)); // first result always 0
end;
end.
And here is the threading unit
unit uCalculationThread;
interface
uses
System.Classes;
type
TCalc = class(TThread)
private
fiOut: Int64;
fnumA, fNumB: Integer;
protected
procedure Execute; override;
public
property numA: Integer read fnumA write fnumA;
property numb: Integer read fNumB write fNumB;
property iOut: Int64 read fiOut write fiOut;
constructor Create;
end;
implementation
constructor TCalc.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
end;
procedure TCalc.Execute;
begin
fiOut := fnumA + fNumB;
end;
end.
What I need is a simple function to have the result from that thread.
Consider this method:
function TForm1.StartCalc(const calA, calB: Integer): Int64;
begin
BeginCal(calA, calB);
Result := nOut;
end;
It calls BeginCal, which creates a thread and starts its execution. The result of the thread is passed through the OnTerminate event which calls CaclDone and assigns the result to the nOut variable.
Since the OnTerminate event is executed in the main thread, this will happen after the execution of StartCalc. Hence, there will be no valid value for StartCalc to return.
What I need is a simple function to have the result from that thread.
This means that the main thread will have to wait for the thread to finish its execution. That defeats the way the GUI is supposed to behave.
You already have a mechanism for getting the result in the CaclDone method.
The way to handle an async calculation chain in this situation is to do something like this (uses System.Threading):
function MyAdd( a,b : Int64): Int64;
begin
Result := a + b;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
TTask.Create(
procedure
var
i: Int64;
begin
i := MyAdd(10,20);
TThread.Queue(nil, // Result is presented in the main thread.
procedure
begin
mmo1.Lines.Add('on function call : ' + IntToStr(i));
if (i <> 4) then
mmo1.Lines.Add('on function call : <> 4');
end);
end).Start;
end;

Return String from Thread Delphi

I'm using Delphi XE6.
I have a thread where I pass a ID and would like to get back a string created by the thread. I looked at all examples, but they all getting values back when thread is running I just need it OnTerminate.
Calling the thread from a form:
StringReturnedFromThread := PrintThread.Create(MacId);
PrintThread = class(TThread)
private
MyReturnStr, PrinterMacId : String;
public
constructor Create(MacId: String); reintroduce;
procedure OnThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
end;
constructor PrintThread.Create(MacId: String);
begin
inherited Create(False);
OnTerminate := OnThreadTerminate;
FreeOnTerminate := True;
PrinterMacId := MacId;
end;
procedure PrintThread.Execute;
begin
PrepareConnection;
MyReturnStr:= RequestPrintJobs(PrinterMacId);
end;
procedure PrintThread.OnThreadTerminate(Sender: TObject);
begin
end;
Thanks for any help.
You need to intercept thread termination. One way is to use TThread.OnTerminate event/callback.
Below a sample code.
Thread unit:
unit Processes;
interface
uses
System.Classes;
type
TProcess = class(TThread)
private
FReturnStr: string;
FMacId: string;
protected
procedure Execute; override;
public
property MacId: string read FMacId write FMacId;
property ReturnStr: string read FReturnStr write FReturnStr;
constructor Create;
end;
implementation
constructor TProcess.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
end;
procedure TProcess.Execute;
begin
// Some hard calculation here
FReturnStr := FMacId + 'BLA';
end;
end.
Thread usage:
uses Processes;
procedure TForm1.Button1Click(Sender: TObject);
var P: TProcess;
begin
// Create the thread
P := TProcess.Create;
// Initialize it
P.MacId := 'MID123';
// Callback handler
P.OnTerminate := OnProcessTerminate;
// Let's go
P.Start;
end;
procedure TForm1.OnProcessTerminate(Sender: TObject);
var P: TProcess;
begin
// The thread has been terminated
P := TProcess(Sender);
ShowMessage(P.ReturnStr);
end;
The thread will return MID123BLA on it's termination.

How to check if a thread is currently running

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.

Why thread code is not executed?

I have 4 threads created at runtime. Each thread enters critical section, changes global variable, exits critical section and shows message dialog with the result. OnThreadTerminate I also have a message dialog. It seems to be random, but still, I sometimes get 3 messages with the result and one saying that thread is terminated. How is it even possible? Win7 x64.
There is my full code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ComCtrls,
IdThreadComponent, idHTTP, SyncObjs;
const
THREAD_NAME = 'MyidThreadComponent';
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
BitBtn1: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
FCriticalSection: TCriticalSection;
FGlobalVariable: integer;
procedure CreateThreads(const ACount: integer; const AStart: boolean);
function GetWebsiteContent(const AURL: string): string;
procedure MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
procedure MyIdThreadComponentOnTerminateHandler(Sender: TIdThreadComponent);
public
{ Public declarations }
property GlobalVariable: integer read FGlobalVariable write FGlobalVariable;
property CriticalSection: TCriticalSection read FCriticalSection;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FCriticalSection := TCriticalSection.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(FCriticalSection);
end;
function TForm1.GetWebsiteContent(const AURL: string): string;
var
_MyidHTTP: TidHTTP;
begin
_MyidHTTP := TidHTTP.Create(self);
try
Result := _MyidHTTP.Get(AURL);
finally
FreeAndNil(_MyidHTTP);
end;
end;
procedure TForm1.MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
var
_LocalVariable: integer;
begin
CriticalSection.Acquire;
try
// Safe way to deal with global variables. Only one thread will enter
// CriticalSection at time.
_LocalVariable := GlobalVariable;
_LocalVariable := _LocalVariable * 2;
GlobalVariable := _LocalVariable;
finally
CriticalSection.Release;
end;
ShowMessage(Sender.Name + ' started: ' + IntToStr(_LocalVariable));
Sender.Terminate;
end;
procedure TForm1.MyIdThreadComponentOnTerminateHandler
(Sender: TIdThreadComponent);
begin
ShowMessage(Sender.Name + ' terminated.');
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
GlobalVariable := 1;
CreateThreads(4 { System.CPUCount + 1 } , true);
end;
procedure TForm1.CreateThreads(const ACount: integer; const AStart: boolean);
var
_MyIdThreadComponent: TIdThreadComponent;
i: integer;
begin
if ACount > 0 then
for i := 1 to ACount do
begin
_MyIdThreadComponent := FindComponent(THREAD_NAME + IntToStr(i))
as TIdThreadComponent;
if not Assigned(_MyIdThreadComponent) then
begin
_MyIdThreadComponent := TIdThreadComponent.Create(self);
_MyIdThreadComponent.Name := THREAD_NAME + IntToStr(i);
_MyIdThreadComponent.Tag := i;
_MyIdThreadComponent.OnRun := MyIdThreadComponentOnRunHandler;
_MyIdThreadComponent.OnTerminate :=
MyIdThreadComponentOnTerminateHandler;
{$IFDEF MSWINDOWS}
_MyIdThreadComponent.Priority := tpNormal;
{$ENDIF}
{$IFDEF MACOS}
_MyIdThreadComponent.Priority := 1;
{$ENDIF}
end;
if AStart = true then
if Assigned(_MyIdThreadComponent) then
_MyIdThreadComponent.Start;
end;
end;
end.
Showmessage is not the best way to show the output as its not thread safe. Instead, if you use a memo or other control and wrap it in a synchronize call it will be easier to see the results. I modified your routine to output to a memo, and included the ThreadId before and inside the synchronize call so you can better understand what is happening.
Keep in mind that your threads will not always output in the order you may think they will, it is entirely possible that thread 4 will output before thread 1, even though thread 1 was started first and 4 last.
procedure TForm13.MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
var
_LocalVariable: integer;
_LocalThreadId : Cardinal;
begin
fCriticalSection.Acquire;
try
// Safe way to deal with global variables. Only one thread will enter
// CriticalSection at time.
_LocalVariable := GlobalVariable;
_LocalVariable := _LocalVariable * 2;
GlobalVariable := _LocalVariable;
finally
fCriticalSection.Release;
end;
_LocalThreadId := TThread.CurrentThread.ThreadID;
TThread.Synchronize(TThread.CurrentThread,procedure begin
memo1.Lines.Add(Format('%s Started (%d/%d): %d',[Sender.Name,_LocalThreadId,TThread.CurrentThread.ThreadID,_LocalVariable]));
end);
Sender.Terminate;
end;
procedure TForm13.MyIdThreadComponentOnTerminateHandler
(Sender: TIdThreadComponent);
begin
// note sync call is not needed as this is executed in the context of the main thread.
memo1.Lines.Add(Format('%s terminated. (%d)',[Sender.Name,TThread.CurrentThread.ThreadID]));
end;

How to manage the return value of a thread?

I created a class derived from TThread that executes in background a query.
I want that this class is decoupled from the client.
This kind of thread has the purpose of executing a simple check (like how many users are currently connected to the application, without blocking the UI), so a simple idea is to use the Synchronize Method.
Anyway since i want it to be decoupled i pass in the constructor a parameter of type
TSyncMethod: procedure of object;
Where TSyncMethod is a method on the client (a form in my case).
Anyway how can I pass the value to TSyncMethod? I should write the result on some "global place" and then inside my TSyncMethod I check for it?
I also tried to think of
TSyncMethod: procedure(ReturnValue: integer) of object;
but of course when I call Synchronize(MySyncMethod) I cannot pass parameters to it.
For such a simply example, you can put the desired value into a member field of the thread (or even into the thread's own ReturnValue property), then Synchronize() execution of the callback using an intermediate thread method, where you can then pass the value to the callback. For example:
type
TSyncMethod: procedure(ReturnValue: integer) of object;
TQueryUserConnected = class(TThread)
private
FMethod: TSyncMethod;
FMethodValue: Integer;
procedure DoSync;
protected
procedure Execute; override;
public
constructor Create(AMethod: TSyncMethod); reintroduce;
end;
constructor TQueryUserConnected.Create(AMethod: TSyncMethod);
begin
FMethod := AMethod;
inherited Create(False);
end;
procedure TQueryUserConnected.Execute;
begin
...
FMethodValue := ...;
if FMethod <> nil then
Synchronize(DoSync);
end;
procedure TQueryUserConnected.DoSync;
begin
if FMethod <> nil then
FMethod(FMethodValue);
end;
Using OmniThreadLibrary:
uses OtlFutures;
var
thread: IOmniFuture<integer>;
thread := TOmniFuture<integer>.Create(
function: integer;
begin
Result := YourFunction;
end;
);
// do something else
threadRes := thread.Value; //will block if thread is not yet done
Creating the TOmniFuture object will automatically start background thread executing your code. Later you can wait on result by calling .Value or you can use .TryValue or .IsDone to check if the thread has already completed its work.
What version of Delphi are you using? If you're on D2009 or newer, you can pass an anonymous method to Synchronize that takes no parameters but references local variables, passing them "under the radar" as part of the closure.
You can try my TCommThread component. It allows you to pass data back to the main thread without worrying about any of the complexities of threads or Windows messages.
Here's the code if you'd like to try it. You can also see some example code here.
CommThread Library:
unit Threading.CommThread;
interface
uses
Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;
const
CTID_USER = 1000;
PRM_USER = 1000;
CTID_STATUS = 1;
CTID_PROGRESS = 2;
type
TThreadParams = class(TDictionary<String, Variant>);
TThreadObjects = class(TDictionary<String, TObject>);
TCommThreadParams = class(TObject)
private
FThreadParams: TThreadParams;
FThreadObjects: TThreadObjects;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function GetParam(const ParamName: String): Variant;
function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
function GetObject(const ObjectName: String): TObject;
function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
end;
TCommQueueItem = class(TObject)
private
FSender: TObject;
FMessageId: Integer;
FCommThreadParams: TCommThreadParams;
public
destructor Destroy; override;
property Sender: TObject read FSender write FSender;
property MessageId: Integer read FMessageId write FMessageId;
property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
end;
TCommQueue = class(TQueue<TCommQueueItem>);
ICommDispatchReceiver = interface
['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure CommThreadTerminated(Sender: TObject);
function Cancelled: Boolean;
end;
TCommThread = class(TThread)
protected
FCommThreadParams: TCommThreadParams;
FCommDispatchReceiver: ICommDispatchReceiver;
FName: String;
FProgressFrequency: Integer;
FNextSendTime: TDateTime;
procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
public
constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
destructor Destroy; override;
function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
function GetParam(const ParamName: String): Variant;
function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
function GetObject(const ObjectName: String): TObject;
procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
property Name: String read FName;
end;
TCommThreadClass = Class of TCommThread;
TCommThreadQueue = class(TObjectList<TCommThread>);
TCommThreadDispatchState = (
ctsIdle,
ctsActive,
ctsTerminating
);
TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;
TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
private
FProcessQueueTimer: TTimer;
FCSReceiveMessage: TCriticalSection;
FCSCommThreads: TCriticalSection;
FCommQueue: TCommQueue;
FActiveThreads: TList;
FCommThreadClass: TCommThreadClass;
FCommThreadDispatchState: TCommThreadDispatchState;
function CreateThread(const ThreadName: String = ''): TCommThread;
function GetActiveThreadCount: Integer;
function GetStateText: String;
protected
FOnReceiveThreadMessage: TOnReceiveThreadMessage;
FOnStateChange: TOnStateChange;
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;
FManualMessageQueue: Boolean;
FProgressFrequency: Integer;
procedure SetManualMessageQueue(const Value: Boolean);
procedure SetProcessQueueTimerInterval(const Value: Integer);
procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure OnProcessQueueTimer(Sender: TObject);
function GetProcessQueueTimerInterval: Integer;
procedure CommThreadTerminated(Sender: TObject); virtual;
function Finished: Boolean; virtual;
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
procedure DoOnStateChange; virtual;
procedure TerminateActiveThreads;
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function NewThread(const ThreadName: String = ''): TCommThread; virtual;
procedure ProcessMessageQueue; virtual;
procedure Stop; virtual;
function State: TCommThreadDispatchState;
function Cancelled: Boolean;
property ActiveThreadCount: Integer read GetActiveThreadCount;
property StateText: String read GetStateText;
property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
end;
TCommThreadDispatch = class(TBaseCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;
TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
protected
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
end;
TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;
implementation
const
PRM_STATUS_TEXT = 'Status';
PRM_STATUS_TYPE = 'Type';
PRM_PROGRESS_ID = 'ProgressID';
PRM_PROGRESS = 'Progess';
PRM_PROGRESS_MAX = 'ProgressMax';
resourcestring
StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
StrIdle = 'Idle';
StrTerminating = 'Terminating';
StrActive = 'Active';
{ TCommThread }
constructor TCommThread.Create(CommDispatchReceiver: TObject);
begin
Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);
inherited Create(TRUE);
FCommThreadParams := TCommThreadParams.Create;
end;
destructor TCommThread.Destroy;
begin
FCommDispatchReceiver.CommThreadTerminated(Self);
FreeAndNil(FCommThreadParams);
inherited;
end;
function TCommThread.GetObject(const ObjectName: String): TObject;
begin
Result := FCommThreadParams.GetObject(ObjectName);
end;
function TCommThread.GetParam(const ParamName: String): Variant;
begin
Result := FCommThreadParams.GetParam(ParamName);
end;
procedure TCommThread.SendCommMessage(MessageId: Integer;
CommThreadParams: TCommThreadParams);
begin
FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
end;
procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
ProgressMax: Integer; AlwaysSend: Boolean);
begin
if (AlwaysSend) or (now > FNextSendTime) then
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
.SetParam(PRM_PROGRESS_ID, ProgressID)
.SetParam(PRM_PROGRESS, Progress)
.SetParam(PRM_PROGRESS_MAX, ProgressMax));
if not AlwaysSend then
FNextSendTime := now + (FProgressFrequency * OneMillisecond);
end;
end;
procedure TCommThread.SendStatusMessage(const StatusText: String;
StatusType: Integer);
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_STATUS, TCommThreadParams.Create
.SetParam(PRM_STATUS_TEXT, StatusText)
.SetParam(PRM_STATUS_TYPE, StatusType));
end;
function TCommThread.SetObject(const ObjectName: String;
Obj: TObject): TCommThread;
begin
Result := Self;
FCommThreadParams.SetObject(ObjectName, Obj);
end;
function TCommThread.SetParam(const ParamName: String;
ParamValue: Variant): TCommThread;
begin
Result := Self;
FCommThreadParams.SetParam(ParamName, ParamValue);
end;
{ TCommThreadDispatch }
function TBaseCommThreadDispatch.Cancelled: Boolean;
begin
Result := State = ctsTerminating;
end;
procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
var
idx: Integer;
begin
FCSCommThreads.Enter;
try
Assert(Sender is TCommThread, StrSenderMustBeATCommThread);
// Find the thread in the active thread list
idx := FActiveThreads.IndexOf(Sender);
Assert(idx <> -1, StrUnableToFindTerminatedThread);
// if we find it, remove it (we should always find it)
FActiveThreads.Delete(idx);
finally
FCSCommThreads.Leave;
end;
end;
constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
begin
inherited;
FCommThreadClass := TCommThread;
FProcessQueueTimer := TTimer.Create(nil);
FProcessQueueTimer.Enabled := FALSE;
FProcessQueueTimer.Interval := 5;
FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
FProgressFrequency := 200;
FCommQueue := TCommQueue.Create;
FActiveThreads := TList.Create;
FCSReceiveMessage := TCriticalSection.Create;
FCSCommThreads := TCriticalSection.Create;
end;
destructor TBaseCommThreadDispatch.Destroy;
begin
// Stop the queue timer
FProcessQueueTimer.Enabled := FALSE;
TerminateActiveThreads;
// Pump the queue while there are active threads
while CommThreadDispatchState <> ctsIdle do
begin
ProcessMessageQueue;
sleep(10);
end;
// Free everything
FreeAndNil(FProcessQueueTimer);
FreeAndNil(FCommQueue);
FreeAndNil(FCSReceiveMessage);
FreeAndNil(FCSCommThreads);
FreeAndNil(FActiveThreads);
inherited;
end;
procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
// Don't send the messages if we're being destroyed
if not (csDestroying in ComponentState) then
begin
if Assigned(FOnReceiveThreadMessage) then
FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
end;
end;
procedure TBaseCommThreadDispatch.DoOnStateChange;
begin
if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
FOnStateChange(Self, FCommThreadDispatchState);
end;
function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
begin
Result := FActiveThreads.Count;
end;
function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
begin
Result := FProcessQueueTimer.Interval;
end;
function TBaseCommThreadDispatch.GetStateText: String;
begin
case State of
ctsIdle: Result := StrIdle;
ctsTerminating: Result := StrTerminating;
ctsActive: Result := StrActive;
end;
end;
function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
begin
if FCommThreadDispatchState = ctsTerminating then
Result := nil
else
begin
// Make sure we're active
if CommThreadDispatchState = ctsIdle then
CommThreadDispatchState := ctsActive;
Result := CreateThread(ThreadName);
FActiveThreads.Add(Result);
if ThreadName = '' then
Result.FName := IntToStr(Integer(Result))
else
Result.FName := ThreadName;
Result.FProgressFrequency := FProgressFrequency;
end;
end;
function TBaseCommThreadDispatch.CreateThread(
const ThreadName: String): TCommThread;
begin
Result := FCommThreadClass.Create(Self);
Result.FreeOnTerminate := TRUE;
end;
procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
begin
ProcessMessageQueue;
end;
procedure TBaseCommThreadDispatch.ProcessMessageQueue;
var
CommQueueItem: TCommQueueItem;
begin
if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
begin
if FCommQueue.Count > 0 then
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := FCommQueue.Dequeue;
while Assigned(CommQueueItem) do
begin
try
DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
finally
FreeAndNil(CommQueueItem);
end;
if FCommQueue.Count > 0 then
CommQueueItem := FCommQueue.Dequeue;
end;
finally
FCSReceiveMessage.Leave
end;
end;
if Finished then
begin
FCommThreadDispatchState := ctsIdle;
DoOnStateChange;
end;
end;
end;
function TBaseCommThreadDispatch.Finished: Boolean;
begin
Result := FActiveThreads.Count = 0;
end;
procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
CommThreadParams: TCommThreadParams);
var
CommQueueItem: TCommQueueItem;
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := TCommQueueItem.Create;
CommQueueItem.Sender := Sender;
CommQueueItem.MessageId := MessageId;
CommQueueItem.CommThreadParams := CommThreadParams;
FCommQueue.Enqueue(CommQueueItem);
finally
FCSReceiveMessage.Leave
end;
end;
procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
const Value: TCommThreadDispatchState);
begin
if FCommThreadDispatchState <> ctsTerminating then
begin
if Value = ctsActive then
begin
if not FManualMessageQueue then
FProcessQueueTimer.Enabled := TRUE;
end
else
TerminateActiveThreads;
end;
FCommThreadDispatchState := Value;
DoOnStateChange;
end;
procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
begin
FManualMessageQueue := Value;
end;
procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
begin
FProcessQueueTimer.Interval := Value;
end;
function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
begin
Result := FCommThreadDispatchState;
end;
procedure TBaseCommThreadDispatch.Stop;
begin
if CommThreadDispatchState = ctsActive then
TerminateActiveThreads;
end;
procedure TBaseCommThreadDispatch.TerminateActiveThreads;
var
i: Integer;
begin
if FCommThreadDispatchState = ctsActive then
begin
// Lock threads
FCSCommThreads.Acquire;
try
FCommThreadDispatchState := ctsTerminating;
DoOnStateChange;
// Terminate each thread in turn
for i := 0 to pred(FActiveThreads.Count) do
TCommThread(FActiveThreads[i]).Terminate;
finally
FCSCommThreads.Release;
end;
end;
end;
{ TCommThreadParams }
procedure TCommThreadParams.Clear;
begin
FThreadParams.Clear;
FThreadObjects.Clear;
end;
constructor TCommThreadParams.Create;
begin
FThreadParams := TThreadParams.Create;
FThreadObjects := TThreadObjects.Create;
end;
destructor TCommThreadParams.Destroy;
begin
FreeAndNil(FThreadParams);
FreeAndNil(FThreadObjects);
inherited;
end;
function TCommThreadParams.GetObject(const ObjectName: String): TObject;
begin
Result := FThreadObjects.Items[ObjectName];
end;
function TCommThreadParams.GetParam(const ParamName: String): Variant;
begin
Result := FThreadParams.Items[ParamName];
end;
function TCommThreadParams.SetObject(const ObjectName: String;
Obj: TObject): TCommThreadParams;
begin
FThreadObjects.AddOrSetValue(ObjectName, Obj);
Result := Self;
end;
function TCommThreadParams.SetParam(const ParamName: String;
ParamValue: Variant): TCommThreadParams;
begin
FThreadParams.AddOrSetValue(ParamName, ParamValue);
Result := Self;
end;
{ TCommQueueItem }
destructor TCommQueueItem.Destroy;
begin
if Assigned(FCommThreadParams) then
FreeAndNil(FCommThreadParams);
inherited;
end;
{ TBaseStatusCommThreadDispatch }
procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;
case MessageId of
// Status Message
CTID_STATUS: DoOnStatus(Sender,
Name,
CommThreadParams.GetParam(PRM_STATUS_TEXT),
CommThreadParams.GetParam(PRM_STATUS_TYPE));
// Progress Message
CTID_PROGRESS: DoOnProgress(Sender,
CommThreadParams.GetParam(PRM_PROGRESS_ID),
CommThreadParams.GetParam(PRM_PROGRESS),
CommThreadParams.GetParam(PRM_PROGRESS_MAX));
end;
end;
procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
StatusText: String; StatusType: Integer);
begin
if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
FOnStatus(Self, Sender, ID, StatusText, StatusType);
end;
procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
const ID: String; Progress, ProgressMax: Integer);
begin
if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
FOnProgress(Self, Sender, ID, Progress, ProgressMax);
end;
end.
To use the library, simply descend your thread from the TCommThread thread and override the Execute procedure:
MyCommThreadObject = class(TCommThread)
public
procedure Execute; override;
end;
Next, create a descendant of the TStatusCommThreadDispatch component and set it's events.
MyCommThreadComponent := TStatusCommThreadDispatch.Create(Self);
// Add the event handlers
MyCommThreadComponent.OnStateChange := OnStateChange;
MyCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
MyCommThreadComponent.OnStatus := OnStatus;
MyCommThreadComponent.OnProgress := OnProgress;
// Set the thread class
MyCommThreadComponent.CommThreadClass := TMyCommThread;
Make sure you set the CommThreadClass to your TCommThread descendant.
Now all you need to do is create the threads via MyCommThreadComponent:
FCommThreadComponent.NewThread
.SetParam('MyThreadInputParameter', '12345')
.SetObject('MyThreadInputObject', MyObject)
.Start;
Add as many parameters and objects as you like. In your threads Execute method you can retrieve the parameters and objects.
MyThreadParameter := GetParam('MyThreadInputParameter'); // 12345
MyThreadObject := GetObject('MyThreadInputObject'); // MyObject
Parameters will be automatically freed. You need to manage objects yourself.
To send a message back to the main thread from the threads execute method:
FCommDispatchReceiver.QueueMessage(Self, CTID_MY_MESSAGE_ID, TCommThreadParams.Create
.SetObject('MyThreadObject', MyThreadObject)
.SetParam('MyThreadOutputParameter', MyThreadParameter));
Again, parameters will be destroyed automatically, objects you have to manage yourself.
To receive messages in the main thread either attach the OnReceiveThreadMessage event or override the DoOnReceiveThreadMessage procedure:
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
Use the overridden procedure to process the messages sent back to your main thread:
procedure THostDiscovery.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;
case MessageId of
CTID_MY_MESSAGE_ID:
begin
// Process the CTID_MY_MESSAGE_ID message
DoSomethingWithTheMessage(CommThreadParams.GetParam('MyThreadOutputParameter'),
CommThreadParams.GeObject('MyThreadObject'));
end;
end;
end;
The messages are pumped in the ProcessMessageQueue procedure. This procedure is called via a TTimer. If you use the component in a console app you will need to call ProcessMessageQueue manually. The timer will start when the first thread is created. It will stop when the last thread has finished. If you need to control when the timer stops you can override the Finished procedure. You can also perform actions depending on the state of the threads by overriding the DoOnStateChange procedure.
Take a look at the TCommThread descendant TStatusCommThreadDispatch. It implements the sending of simple Status and Progress messages back to the main thread.
I hope this helps and that I've explained it OK.
Create a form and add a ListBox , two Buttons, and edit your form. Then use this code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TSyncMethod = procedure(ReturnValue: integer) of object;
TMyThread = class(TThread)
private
fLowerLimit: Integer;
fUpperLimit: Integer;
FMethod: TSyncMethod;
FMethodValue: Integer;
procedure UpdateMainThread;
protected
procedure Execute; override;
public
constructor Create(AMethod: TSyncMethod;lValue, uValue: Integer; Suspended: Boolean);
end;
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
ListBox1: TListBox;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
MyMethod: TSyncMethod;
ReturnValue : Integer;
CountingThread: TMyThread;
procedure MyTest(X : Integer);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TMyThread.Create(AMethod: TSyncMethod;lValue, uValue: Integer; Suspended: Boolean);
begin
FMethod := AMethod;
Inherited Create(Suspended);
fLowerLimit := lValue;
fUpperLimit := uValue;
FreeOnTerminate := True;
Priority := tpLowest;
end;
procedure TMyThread.Execute;
var
I: Integer;
begin
For I := fLowerLimit to fUpperLimit do
if (I mod 10) = 0 then
Synchronize(UpdateMainThread);
FMethod(FMethodValue);
end;
procedure TMyThread.UpdateMainThread;
begin
Form1.ListBox1.Items.Add('Hello World');
FMethodValue := Form1.ListBox1.Count;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MyMethod := MyTest;
CountingThread := TMyThread.Create(MyMethod,22, 999, True);
CountingThread.Resume;
// ShowMessage(IntToStr(ReturnValue));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(Edit1.Text);
end;
procedure TForm1.MyTest(X: Integer);
begin
ShowMessage(IntToStr(X));
end;
end.

Resources