Original Question
In our Delphi XE4 application we use a TOmniEventMonitor to receive messages from other tasks. As long as this is running in the main thread, it works fine, but once I put the same code in a task, the TOmniEventMonitor stops receiving messages. I have included a simple example of this below -- clicking Button_TestInMainThread results in a file being written as expected, clicking Button_TestInBackgroundThread does not. Is this by design, or is there some way to get this working while still using TOmniEventMonitor?
unit mainform;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
OtlTask, OtlTaskControl, OtlComm, OtlEventMonitor;
const
MY_OMNI_MESSAGE = 134;
type
TOmniEventMonitorTester = class(TObject)
fName : string;
fOmniEventMonitor : TOmniEventMonitor;
fOmniTaskControl : IOmniTaskControl;
constructor Create(AName : string);
destructor Destroy(); override;
procedure HandleOmniTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
end;
TTestLauncherTask = class(TOmniWorker)
fOmniTaskMonitorTester : TOmniEventMonitorTester;
function Initialize() : boolean; override;
end;
TForm1 = class(TForm)
Button_TestInMainThread: TButton;
Button_TestInBackgroundThread: TButton;
procedure Button_TestInMainThreadClick(Sender: TObject);
procedure Button_TestInBackgroundThreadClick(Sender: TObject);
private
fOmniEventMonitorTester : TOmniEventMonitorTester;
fTestLauncherTask : IOmniTaskControl;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure OmniTaskProcedure_OneShotTimer(const task: IOmniTask);
begin
Sleep(1000);
task.Comm.Send(MY_OMNI_MESSAGE);
end;
constructor TOmniEventMonitorTester.Create(AName : string);
begin
inherited Create();
fName := AName;
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleOmniTaskMessage;
fOmniTaskControl := fOmniEventMonitor.Monitor(CreateTask(OmniTaskProcedure_OneShotTimer)).Run();
end;
destructor TOmniEventMonitorTester.Destroy();
begin
fOmniEventMonitor.Free();
inherited Destroy();
end;
procedure TOmniEventMonitorTester.HandleOmniTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + fName + '.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, fName);
CloseFile(F);
end;
function TTestLauncherTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniTaskMonitorTester := TOmniEventMonitorTester.Create('background');
end;
end;
procedure TForm1.Button_TestInMainThreadClick(Sender: TObject);
begin
fOmniEventMonitorTester := TOmniEventMonitorTester.Create('main');
end;
procedure TForm1.Button_TestInBackgroundThreadClick(Sender: TObject);
begin
fTestLauncherTask := CreateTask(TTestLauncherTask.Create()).Run();
end;
end.
Additional Observations
With the following code it seems to be possible to successfully use a TOmniEventMonitor within a background thread. This really is a very clumsy solution -- an IOmniTwoWayChannel gets created but not used in any meaningful way -- but as soon as I try to simplify the code by commenting out either of the lines marked "don't remove!", HandleTaskMessage doesn't get called any more. Can anybody tell me what I am doing wrong here?
unit mainform;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
DSiWin32, GpLists, OtlTask, OtlTaskControl, OtlCommon, OtlComm, OtlEventMonitor;
const
MY_OMNI_MESSAGE = 134;
type
TOmniEventMonitorTestTask = class(TOmniWorker)
fOmniTaskControl : IOmniTaskControl;
fOmniTwoWayChannel : IOmniTwoWayChannel;
fOmniEventMonitor : TOmniEventMonitor;
function Initialize() : boolean; override;
procedure HandleTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
procedure HandleTaskTerminated(const task: IOmniTaskControl);
end;
TForm1 = class(TForm)
Button_TestInBackgroundThread: TButton;
procedure Button_TestInBackgroundThreadClick(Sender: TObject);
private
fTestTask : IOmniTaskControl;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure OmniTaskProcedure_OneShotTimer(const task: IOmniTask);
begin
Sleep(1000);
task.Comm.Send(MY_OMNI_MESSAGE); // don't remove!
(task.Param['Comm'].AsInterface as IOmniCommunicationEndpoint).Send(MY_OMNI_MESSAGE);
end;
procedure TOmniEventMonitorTestTask.HandleTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + 'HandleTaskMessage.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, 'HandleTaskMessage!');
CloseFile(F);
end;
procedure TOmniEventMonitorTestTask.HandleTaskTerminated(const task: IOmniTaskControl);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + 'HandleTaskTerminated.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, 'HandleTaskTerminated!');
CloseFile(F);
end;
function TOmniEventMonitorTestTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleTaskMessage;
fOmniEventMonitor.OnTaskTerminated := HandleTaskTerminated;
fOmniTwoWayChannel := CreateTwoWayChannel();
Task.RegisterComm(fOmniTwoWayChannel.Endpoint1); // don't remove!
fOmniTaskControl := fOmniEventMonitor.Monitor( CreateTask(OmniTaskProcedure_OneShotTimer) ).SetParameter('Comm', fOmniTwoWayChannel.Endpoint2).Run();
end;
end;
procedure TForm1.Button_TestInBackgroundThreadClick(Sender: TObject);
begin
fTestTask := CreateTask(TOmniEventMonitorTestTask.Create()).Run();
end;
end.
There is no problem with TOmniEventMonitor running inside of a thread, provided there is a message pump handling the messages for it. I put this block of code together to demonstrate. This works as expected.
procedure TMyThread.Execute;
var
Message: TMsg;
begin
FreeOnTerminate := True;
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleOmniTaskMessage;
fOmniTaskControl := fOmniEventMonitor.Monitor(CreateTask(OmniTaskProcedure_OneShotTimer)).Run();
try
while not Terminated do
begin
if MsgWaitForMultipleObjects(0, nil^, False, 1000, QS_ALLINPUT) = WAIT_OBJECT_0 then
begin
while PeekMessage(Message, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
end;
end;
finally
fOmniTaskControl := nil;
fOmniEventMonitor.Free;
end;
end;
From what I can see, the TOmniTaskExecutor waits for messages to specific handles. In your code example, it's the terminate event and a couple of comm handles. The messages for the TOmniEventMonitor are never processed.
Changing your TTestLauncherTask.Initialize to the following results in it correctly writing out the file. DoNothingProc is just an empty method on the class.
function TTestLauncherTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniTaskMonitorTester := TOmniEventMonitorTester.Create('background');
// Tell the task about the event monitor
Task.RegisterWaitObject(fOmniTaskMonitorTester.fOmniEventMonitor.MessageWindow, DoNothingProc);
end;
end;
I am adding the message window for the TOmniEventMonitor to the Task WaitObject list so the handle is then registered with the MsgWaitForMultipleObjectsEx call and waiting for Remi and David to tear my message handling to shreds :)
Related
I have a TTimer on a TForm, where the timer is set to 5 seconds and creates 100 threads to fetch XML from a remote server.
Each time a thread is executed, I add the XML to a variable (FullXML_STR:String).
When all threads have finished, I am sending the FullXML_STR to all Clients connected to a TIdTCPServer.
unit Unit1;
interface
uses
IdGlobal,IdContext, system.win.Comobj, system.syncObjs, MSXML2_TLB, activex,
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, IdCustomTCPServer, IdCustomHTTPServer,
IdHTTPServer, Vcl.ExtCtrls;
Type
TxClientThread = class(TThread)
private
fHttpClient: TIdHTTP;
furl: String;
ftag:Integer;
fResponseXML:String;
fXML: IXMLDOMDocument;
fNode: IXMLDomNode;
protected
procedure Execute; override;
procedure DoTerminate; override; **//Added**
public
constructor Create(atag:Integer;AURL:string);reintroduce;
destructor Destroy; override;
end;
type
TForm1 = class(TForm)
IdTCPServer1: TIdHTTPServer;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure StartTimerAgain;
end;
const
maximumThreads=200;
var
Form1: TForm1;
Threads_downloaded:Integer;
Total_threads:Integer;
FullXML_STR:String;
Clients:TList;
CriticalSection:TCriticalSection;
ClientThread:Array[0..maximumThreads] of TxClientThread;
implementation
{$R *.dfm}
{TxClientThread}
constructor TxClientThread.Create(atag:Integer;AURL:string);
begin
inherited Create(false);
furl:=Aurl;
ftag:=Atag;
fResponseXML:='';
fHttpClient := TIdHTTP.Create(nil);
fHttpClient.Tag:=ftag;
fHttpClient.ConnectTimeout:=60000;
fHttpClient.ReadTimeout:=60000;
fHttpClient.Request.Accept:='*/*';
fHttpClient.Request.UserAgent:='Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';
FreeOnTerminate := True;
end;
destructor TxClientThread.Destroy;
begin
fHttpClient.Free;
inherited Destroy;
end;
procedure TxClientThread.Execute;
begin
try
fResponseXML:= fHttpClient.Get(furl);
except
end;
end;
procedure TxClientThread.DoTerminate;
begin
inc(Threads_downloaded);
///****** parsing The XML
try
CoInitialize(nil);
fXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
fXML.async := false;
try
fXML.loadXML(fResponseXML);
fNode := fXML.selectSingleNode('/games');
if fNode<>nil then
begin
FullXML_STR:=FullXML_STR + fNode.attributes.getNamedItem('id').text+'^';
end;
finally
fxml:=nil; //---> do i need this?
end;
finally
CoUninitialize;
end;
if Threads_downloaded=Total_threads then
begin
TThread.Synchronize(nil,procedure/////////Sould i USe This or Synchronize
var
i:Integer;
begin
CriticalSection.enter;
if not Assigned(Form1.IdTCPServer1.Contexts) then exit;
try
Clients:=Form1.IdTCPServer1.Contexts.LockList;
try
for i:=pred(Clients.Count) downto 0 do
try
TIdContext(Clients[i]).Connection.IOHandler.Writeln(FullXML_STR,IndyTextEncoding_UTF8);
except
end;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
finally
CriticalSection.leave;
end;
form1.StartTimerAgain; ///Startinmg againe Then timer
end
);
end;
/////////// End \ All threads downloaded
inherited;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CriticalSection:=TCriticalSection.create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
CriticalSection.Free;
end;
procedure tform1.StartTimerAgain;
begin
Form1.Timer1.Enabled:=true
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
x:Integer;
aUrl:String;
begin
FullXML_STR:='';
Timer1.Enabled:=false;
Threads_downloaded:=0;
Total_threads=100;
for x:=0 to Pred(Total_threads) do
begin
aUrl:='http://example.com/myxml'+Formatfloat('0',x)+'.xml';
ClientThread[Threads_downloaded]:=TxClientThread.Create(x,aUrl);
end;
end;
end.
main problem is that after 1-2 Hours programm is not responding.
in each thread's Execute(), I check if all Threads have finished downloading. Is there a better way to know that all my threads are finished?
is it better to call Contexts.LockList() on the TIdTCPServer before the timer starts creating the threads, and unlock it after the threads are finished?
What can I do to optimize my code so I can be sure that the timer will be alive all the time? I am restarting the timer after all threads are finished.
Is this the correct way to do it?
Request:
How is it possible to accept a string like hi from a client connected on the TIdTCPServer and send back a string.
I try to add the following code:
var
RxBuf: TIdBytes;
Data := TxClientContext(AContext).ExtractQueuedStrings;
if Data <> nil then
try
for i := 0 to Pred(Data.Count) do
AContext.Connection.IOHandler.WriteLn(Data[i]);
finally
Data.Free;
end;
RxBuf := nil;
with AContext.Connection do
begin
IOHandler.CheckForDataOnSource(100);
if not IOHandler.InputBufferIsEmpty then
begin
InputBuffer.ExtractToBytes(RxBuf); //for TIdBytes
AContext.Connection.IOHandler.WriteLn('hello');
end;
end;
After sending hello the app never sends data from the queue.
How can I add the hello to Data extract from queue?
Something like this:
Data := TxClientContext(AContext).ExtractQueuedStrings;
and then
data.text:=data.text +'hello data';
or how can I add the 'hello data' in the queue?
I see a lot of mistakes in your code. Rather than pointing them out individually, I would suggest just rewritting the entire code, especially since you are also asking for optimizations.
Try something more like this instead:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
IdGlobal, IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdCustomTCPServer,
IdTCPServer, IdThreadSafe;
type
TIdTCPServer = class(IdTCPServer.TIdTCPServer)
protected
procedure DoTerminateContext(AContext: TIdContext); override;
end;
TForm1 = class(TForm)
IdTCPServer1: TIdTCPServer;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
private
{ Private declarations }
IDs: TIdThreadSafeString;
Threads: TList;
procedure ThreadTerminated(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
System.Win.Comobj, MSXML2_TLB, ActiveX, System.SyncObjs, IdHTTP, IdYarn;
{$R *.dfm}
const
maximumThreads = 100;//200;
{TxClientContext}
type
TxClientContext = class(TIdServerContext)
private
fQueue: TIdThreadSafeStringList;
fInQueue: TEvent;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure AddStringToQueue(const S: string);
function ExtractQueuedStrings: TStrings;
end;
constructor TxClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
fQueue := TIdThreadSafeStringList.Create;
fInQueue := TEvent.Create(nil, True, False, '');
end;
destructor TxClientContext.Destroy; override;
begin
fQueue.Free;
fInQueue.Free;
inherited;
end;
procedure TxClientContext.AddStringToQueue(const S: string);
var
List: TStringList;
begin
List := fQueue.Lock;
try
List.Add(S);
fInQueue.SetEvent;
finally
fQueue.Unlock;
end;
end;
function TxClientContext.ExtractQueuedStrings: TStrings;
var
List: TStringList;
begin
Result := nil;
if fInQueue.WaitFor(INFINITE) <> wrSignaled then Exit;
List := FQueue.Lock;
try
if List.Count > 0 then
begin
Result := TStringList.Create;
try
Result.Assign(List);
List.Clear;
except
Result.Free;
raise;
end;
end;
fInQueue.ResetEvent;
finally
fQueue.Unlock;
end;
end;
{TxClientThread}
type
TxClientThread = class(TThread)
private
fURL: String;
protected
procedure Execute; override;
public
GameID: string;
constructor Create(AURL: string; AOnTerminate: TNotifyEvent); reintroduce;
end;
constructor TxClientThread.Create(AURL: string; AOnTerminate: TNotifyEvent);
begin
inherited Create(False);
fURL := AURL;
OnTerminate := AOnTerminate;
FreeOnTerminate := True;
end;
procedure TxClientThread.Execute;
var
HttpClient: TIdHTTP;
ResponseXML: String;
XML: IXMLDOMDocument;
Node: IXMLDomNode;
begin
HttpClient := TIdHTTP.Create(nil);
try
HttpClient.ConnectTimeout := 60000;
HttpClient.ReadTimeout := 60000;
HttpClient.Request.Accept := '*/*';
HttpClient.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';
ResponseXML := HttpClient.Get(fURL);
finally
HttpClient.Free;
end;
CoInitialize(nil);
try
XML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
try
XML.async := False;
XML.loadXML(ResponseXML);
Node := XML.selectSingleNode('/games');
if Node <> nil then
try
GameID := Node.attributes.getNamedItem('id').text;
finally
Node := nil;
end;
finally
XML := nil;
end;
finally
CoUninitialize;
end;
end;
{TIdTCPServer}
procedure TIdTCPServer.DoTerminateContext(AContext: TIdContext);
begin
inherited; // <-- closes the socket
TxClientContext(AContext).FInQueue.SetEvent; // unblock OnExecute if it is waiting for data...
end;
{TForm1}
procedure TForm1.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TxClientContext;
IDs := TIdThreadSafeString.Create;
Threads := TList.Create;
Threads.Capacity := maximumThreads;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
IDs.Free;
Threads.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
x: Integer;
Thread: TxClientThread;
begin
Timer1.Enabled := False;
IDs.Value := '';
for x := 0 to Pred(maximumThreads) do
begin
Thread := TxClientThread.Create('http://example.com/myxml' + IntToStr(x) + '.xml', ThreadTerminated);
try
Threads.Add(TObject(Thread));
except
Thread.Free;
raise;
end;
end;
end;
proccedure TForm1.ThreadTerminated(Sender: TObject);
var
Clients: TList;
s: string;
i: Integer;
begin
try
s := TxClientThread(Sender).GameID;
if s <> '' then IDs.Append(s + '^');
finally
Threads.Remove(Sender);
end;
if (Threads.Count > 0) or (not Assigned(IdTCPServer1.Contexts)) then Exit;
s := IDs.Value;
if s = '' then Exit;
Clients := IdTCPServer1.Contexts.LockList;
try
for i := Pred(Clients.Count) downto 0 do
try
TxClientContext(TIdContext(Clients[i])).AddStringToQueue(s);
except
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
Timer1.Enabled := True;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Data: TStrings;
i: Integer;
begin
Data := TxClientContext(AContext).ExtractQueuedStrings;
if Data <> nil then
try
for i := 0 to Pred(Data.Count) do
AContext.Connection.IOHandler.WriteLn(Data[i]);
finally
Data.Free;
end;
end;
end.
In each thread, you add the resulting string into a global variable. That is not a safe operation. Instead, add an OnTerminate handler to your threads, where you add the result and also can keep track of the threads.
This is safe, since the OnTerminate handler is executed in the main thread.
I suggest to pass a callback method to pass the result. It is declared like:
type
TSyncMethod = procedure(const ReturnValue: String) of object;
Change the thread accordingly:
Type
TxClientThread = class(TThread)
private
furl : String;
ftag : Integer;
fCallbackMethod : TSyncMethod;
fXMLResult : String;
procedure AfterWork(Sender : TObject);
...
public
constructor Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod); reintroduce;
...
end;
Add a callback method to your form:
Type
TForm1 = Class(TForm1)
private
// Put your "global" variables here
Threads_downloaded : Integer;
Total_threads : Integer;
FullXML_STR : String;
procedure ManageThreadReturnValue(const ReturnValue : String); // Callback from threads
...
end;
The implementation part:
constructor TxClientThread.Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod);
begin
inherited Create(false);
furl := Aurl;
ftag := Atag;
fCallbackMethod := CallbackMethod;
fXMLResult := '';
OnTerminate := AfterWork; // Execute AfterWork when thread terminates (in main thread)
FreeOnTerminate := True;
end;
procedure TxClientThread.Execute;
var
lHttpClient : TIdHTTP;
lResponseXML :String;
lXML : IXMLDOMDocument;
lNode : IXMLDomNode;
begin
lHttpClient := TIdHTTP.Create(nil);
try
lHttpClient.Tag := ftag;
lHttpClient.ConnectTimeout := 60000;
lHttpClient.ReadTimeout := 60000;
lHttpClient.Request.Accept := '*/*';
lHttpClient.Request.UserAgent :=
'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';
try
lResponseXML:= lHttpClient.Get(fUrl);
except
end;
finally
lHttpClient.Free;
end;
///****** parsing The XML
CoInitialize(nil);
try
lXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
lXML.async := false;
try
lXML.loadXML(lResponseXML);
lNode := lXML.selectSingleNode('/games');
if lNode<>nil then
begin
fXMLResult := lNode.attributes.getNamedItem('id').text+'^';
end;
finally
lnode := nil;
lxml := nil; //---> Q: do i need this?
//---> A: Yes, it must be finalized before CoUnitialize
end;
finally
CoUninitialize;
end;
end;
procedure TxClientThread.AfterWork;
begin
if Assigned(fCallbackMethod) then
fCallbackMethod(fXMLResult); // Pass data
end;
procedure TForm1.ManageThreadReturnValue(const ReturnValue : String);
var
i : Integer;
Clients : TList;
begin
// Take care of the return value and other things related to
// what happens when a thread ends.
FullXML_STR := FullXML_STR + ReturnValue;
Inc(threads_downloaded);
if Threads_downloaded = Total_threads then
begin
if Assigned(IdTCPServer1.Contexts) then
begin
Clients:= IdTCPServer1.Contexts.LockList;
try
for i:= Pred(Clients.Count) downto 0 do
begin
try
TIdContext(Clients[i]).Connection.IOHandler.Writeln(
FullXML_STR,IndyTextEncoding_UTF8);
except
end;
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
StartTimerAgain; ///Starting again The timer
end;
end;
// Initiate threads
FullXML_STR:='';
Timer1.Enabled:=false;
Threads_downloaded:=0;
Total_threads=100;
for x:= 0 to Pred(Total_threads) do
begin
aUrl:='http://example.com/myxml'+Formatfloat('0',x)+'.xml';
TxClientThread.Create(x,aUrl,ManageThreadReturnValue); // !! Never keep a reference to a thread with FreeOnTerminate = true
end;
Some other hints:
Put your global variables into the private section of TForm1. This is the place where they belong.
Remove the ClientThread array, since a reference to a thread with FreeOnTerminate = true should never be used.
Do not swallow exceptions, i.e. empty except end clauses are not a good practice.
By using the callback method, you decouple the thread from code/data that does not belong to the thread. That is one of the most important lessons to learn when programming (i.e. avoid making spaghetti code).
i have this TThread that i use inside my dll to update some visual control its working fine but i face issue when i try to close my dll and reopen it again its raised this exception
checksynchronize called from thread which is not the main thread
what iam doing wrong ? i need to call checksynchronize within timer because i will update some vcl with Threading while app running .
Here is my Thread unit
unit Thread;
interface
uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
ShlObj;
{ Thread client }
type
TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;
TAPPTHREAD = class(TThread)
private
Fstatus : String;
FOnCallbackProc: TThreadCallbackProc;
procedure dosomework;
procedure DoCallbackProc;
//
protected
procedure Execute; override;
Public
constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
destructor Destroy; override;
end;
var
APPTHREAD : TAPPTHREAD;
implementation
constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
aThreadCallbackProc: TThreadCallbackProc);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FOnCallbackProc := aThreadCallbackProc;
end;
destructor TAPPTHREAD.Destroy;
begin
//
end;
procedure TAPPTHREAD.DoCallbackProc;
begin
if Assigned(FOnCallbackProc) then
FOnCallbackProc(self, Fstatus);
end;
procedure TAPPTHREAD.Execute;
begin
while not Terminated do
begin
Fstatus := 'Synched';
if Fstatus <> '' then
dosomework;
end;
end;
procedure TAPPTHREAD.dosomework;
begin
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
end.
Main Form
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.ExtCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure callbackproc(Sender: TObject; Updatestring : String);
end;
var
Form1: TForm1;
implementation
uses Thread;
{$R *.dfm}
procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;
try
Timer2.Enabled := False;
except end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;
end.
DFM
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 242
ClientWidth = 472
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 0
Top = 0
Width = 472
Height = 13
Align = alTop
Caption = 'Label1'
ExplicitLeft = 232
ExplicitTop = 136
ExplicitWidth = 31
end
object Timer1: TTimer
Enabled = False
OnTimer = Timer1Timer
Left = 232
Top = 128
end
object Timer2: TTimer
Enabled = False
Interval = 1
OnTimer = Timer2Timer
Left = 320
Top = 168
end
end
dll code
library dllapp;
uses
System.SysUtils,
Themes,
Windows,
Forms,
dialogs,
Graphics,
Vcl.ExtCtrls,
Unit1 in 'Unit1.pas' {Unit1},
DThreadsend in 'Thread.pas';
var
mHandle: THandle;
DLLHandle: Longint = 0;
function createApp(Width: Integer; Height: Integer; hw: HWnd;
app: TApplication): boolean; stdcall;
begin
mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Halt;
end;
try
form1 := Tform1.CreateParented(hw); // **
form1.Width := Width;
form1.Height := Height;
Result := True
except
on e: exception do
begin
Result := False;
end;
end;
end;
procedure closeApp; stdcall;
begin
ApplicationClosed := True;
try
if mHandle <> 0 then
CloseHandle(mHandle);
except
end;
if Assigned(form1) then
try
FreeAndNil(form1);
except
end;
try
OptimizeRamUsage;
except
end;
end;
procedure showapp; stdcall;
begin
try
form1.Visible := True;
except
end;
form1.Show;
end;
procedure DLLEntryProc(EntryCode: Integer);
begin
case EntryCode of
DLL_PROCESS_DETACH:
begin
StyleServices.Free;
end;
DLL_PROCESS_ATTACH:
begin
end;
DLL_THREAD_ATTACH:
begin
end;
DLL_THREAD_DETACH:
begin
end;
end;
end;
exports
closeApp,
createApp,
showapp;
begin
DllProc := #DLLEntryProc;
end.
Host Application and how i create Dll
loadapp Unit
unit loadapp;
interface
uses windows, forms, System.SysUtils , dialogs;
procedure loadmainapp;
type
TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
TshowFunc = procedure stdcall;
TCloseAppFunc = procedure stdcall;
var
dllHandle : THandle = 0;
creaFunc : TcreaFunc;
showFunc : TshowFunc;
CloseAppFunc: TCloseAppFunc;
implementation
uses Mainapp;
procedure loadmainapp;
var
S: widestring;
PW: PWideChar;
begin
S := 'dllapp.dll';
pw:=pwidechar(widestring(s));
dllHandle := LoadLibrary(pw);
if dllHandle <> 0 then
begin
#creaFunc := GetProcAddress(dllHandle, 'createApp');
#showFunc := GetProcAddress(dllHandle, 'showapp');
if Assigned (creaFunc) then
begin
creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
DisFunc;
end
else
ShowMessage('ERROR');
end
else
begin
ShowMessage('ERROR');
end;
end;
end.
Active Form
unit activeform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;
type
TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
mpanl: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
end;
implementation
uses ComObj, ComServ, Mainapp, libacload;
{$R *.DFM}
{ TActiveFrmldr }
procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
#CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle); //release dll
end;
if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;
end;
procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;
procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFrmldr,
Class_ActiveFrmldr,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
finalization
end.
Main app Form that call load library function
unit Mainapp;
interface
uses
Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
Vcl.Controls, Vcl.StdCtrls;
type
Tmainfrm = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
mainfrm: Tmainfrm;
implementation
Uses loadapp;
{$R *.dfm}
procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
loadmainapp;
end;
procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin
checksynchronize; // i do this to check some thread in activex it self
end;
end.
The error means that CheckSynchronize() is being called in a thread whose ThreadID does not match the RTL's global System.MainThreadID variable.
A DLL does not have a main thread of its own. MainThreadID gets initialized to whatever thread is initializing the DLL. So, if your DLL is creating its GUI in a different thread than the one that is initializing your DLL, CheckSynchronize() (and TThread.Synchronize(), and TThread.Queue()) will not work unless you manually update the MainThreadID variable to the ThreadID that is running your GUI. Do that before creating your worker thread, eg:
if IsLibrary then
MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);
Or:
procedure TForm1.FormCreate(Sender: TObject);
begin
if IsLibrary then
MainThreadID := GetCurrentThreadID;
end;
Or:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
if IsLibrary then
MainThreadID := GetCurrentThreadID;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
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;
I want to terminate thread by clicking the button. If the thread normally works without user interruption it is OK but sometimes user needs to abort thread and that's the question that how user abort the thread.
Here is my code that I tested:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, mmsystem, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
procedure Image1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
type
hangth = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
procedure play;
end;
var
Form1: TForm1;
played: boolean;
szalhang: hangth;
implementation
{$R *.dfm}
procedure hangth.play;
begin
played := true;
szalhang.Terminate;
end;
procedure hangth.Execute;
begin
played := false;
SndPlaySound(pchar('hang.wav'), SND_SYNC);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
played := true;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if played = true then begin
szalhang := hangth.Create(true);
szalhang.Resume;
end else begin
szalhang.Terminate();
// here i want to terminate thread, but it doesn't want to be killed.
end;
end;
end.
When you call TThread.Terminate(), it sets the TThread.Terminated property to true and does nothing else. It is the responsibility of your TThread.Execute() code to look at the TThread.Terminated property periodically and exit gracefully when it is True. However, in this situation, that is not possible because SndPlaySound() is blocking the thread, and there is no way to interrupt SndPlaySound() when it is running in SND_SYNC mode. Your only option would be to use the Win32 API TerminateThread() function to perform a brute-force termination of the thread.
Since you obviously need more control over the playback of the audio, and detection of when the audio is finished playing, then SndPlaySound() is not the best solution for your needs. You have a TForm, you might consider using Delphi's TMediaPlayer component, for example:
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.ExtCtrls, Vcl.MPlayer;
type
MPlayerState = (mpsClosed, mpsOpened, mpsPlaying);
TForm1 = class(TForm)
Image1: TImage;
MediaPlayer1: TMediaPlayer;
procedure MediaPlayer1Notify(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Image1Click(Sender: TObject);
private
{ Private declarations }
State: MPlayerState;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm56.FormCreate(Sender: TObject);
begin
State := mpsClosed;
MediaPlayer1.FileName := 'C:\full path to\hang.wav';
end;
procedure TForm56.MediaPlayer1Notify(Sender: TObject);
begin
case MediaPlayer1.Mode of
mpStopped, mpPlaying:
State := mpsOpened;
end;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if State = mpsClosed then
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Open;
State := mpsOpened;
end;
if State = mpsOpened then
begin
MediaPlayer1.Notify := True;
MediaPlayer1.Wait := False;
MediaPlayer1.Play;
if MediaPlayer1.Error = 0 then
State := mpsPlaying
end else
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Stop;
State := mpsOpened;
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Close;
State := mpsClosed;
end;
end;
end.
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;