My FireMonkey app has a save button that does this:
procedure TFormProductionRuns.buSaveFinishProductClick(Sender: TObject);
begin
ShowActivity;
ITask(TTask.Create(
procedure
begin
try
TThread.Synchronize(nil,
procedure
begin
PostFinishProduct;
end);
finally
TThread.Synchronize(nil,
procedure
begin
HideActivity;
end);
end;
end)).Start;
end;
The activity methods are defined as:
procedure TFormProductionRuns.ShowActivity;
begin
frProgress1.ShowActivity;
end;
procedure TFormProductionRuns.HideActivity;
begin
frProgress1.HideActivity;
end;
procedure TfrProgress.ShowActivity;
begin
Self.Visible := True;
ProgFloatAnimation.Enabled := True;
end;
procedure TfrProgress.HideActivity;
begin
ProgFloatAnimation.Enabled := False;
Self.Visible := False;
end;
The frame is set to align content, so fills up the entire app screen when visible, and contains a "busy" animation. The bulk of the work is a REST request to a post web method.
procedure TFormProductionRuns.PostFinishProduct;
var
AList: TObjectList<TFinishedProduct>;
sReqBody, sResponse: String;
begin
...
sReqBody := TJSONUtils.ObjectsToJSONArray<TFinishedProduct>(AList).ToString;
RESTReqPostTransaction.Params.ParameterByName('ReqBody').Value := sReqBody;
RESTClient1.Params.ParameterByName('host_port').Value := FLoginInfo.Server + ':' + FLoginInfo.Port;
HTTPBasicAuthenticator1.Username := FLoginInfo.LoginId;
HTTPBasicAuthenticator1.Password := FLoginInfo.LoginPw;
try
RESTReqPostTransaction.Execute;
except on E:Exception do
begin
ShowMessage('Post Finish Product failed. Exception: ' + E.Message);
Exit;
end;
end;
sResponse := RESTResponseFromPost.Content;
...
end;
What I'm finding is that the animation stops while this request is being processed, but my understanding was that the main thread would continue while the worker thread was waiting for the response.
The app does have a similar method that uses a Get REST request rather than Post, and that has no problems animating the "busy" graphic while the worker thread is waiting for the response.
TThread.Synchronize is a method which request execution by the main thread of the method passed in synchronize argument. This actually completely defeat multi-threading.
You have to design you thread so that synchronize is only use for very short actions such as updating the user interface or pass data between the worker thread and main thread because when synchronize is called, the thread is waiting (It is stopped) for the method passed in argument to be executed by the main thread. And while the main thread execute that method, it doesn't do anything else (And you animation stop).
Related
I am using TOmniBlockingCollection from a "Server Thread".
In this thread, I am hosting a Single-Threaded Apartment COM object to a DataProvider (CoInitialize() and CoUninitialize() are called).
Then additionally, I am using multiple worker threads to write to an ADO Dataset (TADOCommand), which also needs CoInitialize()/CoUninitialize().
Only when I catch an error from inside the WorkerFunction and try to terminate the "Server Thread", I am waiting (infinitely?) on the CoUninitialize() in the "Server Thread" (inherited from TThread) that started the WorkerFunction.
Callstack:
:774546bc ntdll.ZwWaitForAlertByThreadId + 0xc
.... some other system functions
:771e8069 combase.CoUninitialize + 0xf9
UTServerThread.TServerThread.Execute (calls CoUninitialize)
How do I avoid the wait in the Server Thread when I catch an error ... it seems to be something COM-related in multi-threading.
Pseudo Code:
procedure CreateIOmniWorkers;
begin
for Each IOmniWorker in OmniWorkerArry
begin
IOmniWorker := CreateTask("WorkerFunction" as TOmniTaskMethod, Description)
.SetParameter('Input', InputCollection)
.WithLock(TSynchroObject.Create) // The Used Logger inside Worker Funtion needs a Lock
.OnTerminated(ErrorHandler);
end;
end;
procedure ErrorHandler(const task: IOmniTaskControl);
var
eException: Exception;
begin
if Assigned(task.FatalException) then
begin
eException := task.DetachException;
try
Logger.Error(
'TOTLBlockingListWorker', eException.ClassName,
Format(rsScriptErrorDataBlock,[eException.Message, eException.StackTrace]));
finally
FreeAndNil(eException);
end;
end;
end;
procedure WorkerFunction(const task: IOmniTask; var SyncData: TSyncOutputValueHolder);
begin
CoInitialize(nil);
try
CreateConnection(SyncData);
// Somewhere here a Exception happens
WriteSQLStyle(task, SyncData);
finally
CoUninitialize; // is called
end;
end;
procedure UTServerThread.TServerThread.Execute
begin
CoInitialize(nil);
try
while not Terminated
begin
CreateIOmniWorkers;
with TOTLBlockingCollection do
while DataAvailable
TOTLBlockingCollection.Add(Datapackage);
TOTLBlockingCollection.CompleteAdding;
while not TOTLBlockingCollection.IsFinalized
Sleep(250);
end;
finally
CoUninitialize; // Here the (infinite?) Wait happens.
end;
end;
I had also some Other Problem with the BlockingList.
if a Exception occured Inside the TryTake until False Loop of the Blocking List Interfaced objects would not be freed.
So i did deperately update my OTL Source to the current Version (3.07.8 was 07.6).
The Problem with CoInitialize and Unitialize is gone... But... i must have still a bug in the Composition.
In place of the OnTerminadted Handler i attached A Monitor to my CreateIOmniWorkers, but i dont receive Events there. The OnTerminated Handler also does not Fire. So it works... But i am not confident that i did it right.
repeat
if not BlockingList.TryTake(Params) then
break; // simplified
InterfacedObject := TInferfacedObject.Create as ISomething
try
raise Exception while having a TInterfacedObject here ...
Finally
InterfaceObject := nil; // if this finally is here in case of Error the Interface would not be freed.
end;
until false
I wrote a communication class based on TThread, which would send some data and receive a reply.
I want the method to:
sent the data (this is a non blocking procedure)
wait for a reply or timeout
show the data received in a vcl control
give back control to the caller
Here is how I try to do,
procedure TForm1.Button1Click(Sender: TObject);
begin
for i := 1 to 5 do // send 5 commands
mycomm.SendCommand();
end;
procedure TMyComm.ShowData();
begin
Form1.Memo1.Lines.Add('Frame received');
end;
procedure TMyComm.SendCommand();
begin
//build frame and put it on interface here
//...
event.WaitFor(3000);
//show received frame if no timeout in VCL
//...
end;
procedure TMyComm.Execute();
begin
while not Terminated do
begin
if receive() then //blocks until frame is received
begin
Synchronize(ShowData); //hangs :-(
event.SetEvent;
end;
end,
end;
Of course this will result in a deadlock, but how can I achieve that my VCL is updated immediately after each received frame?
You can use a anonymous thread, this will only execute the rest of the code after the thread has finished, change it to suite your needs.
You can find the AnonThread Unit in :
C:\Users\Public\Documents\RAD Studio\12.0\Samples\Delphi\RTL\CrossPlatform Utils
uses
AnonThread
var
GetFrame :TAnonymousThread<Boolean>;
begin
GetFrame := TAnonymousThread<Boolean>.Create(function : Boolean
begin
// Start your execution
end,
procedure (AResult : Boolean)
begin
// Wil only execute after the thread has run its course, also safe to do UI updates
end,
procedure (AException : Exception)
begin
ShowMessage('Error : ' + AException.Message);
end);
My database is in a VPS and I should get some query from my tables
Because of getting query from server taking long time ( depending on Internet speed ! ) , I want to use threads to get queries
Now I create a thread and get query and then send result to my forms with sending and handling messages
I want to know is it possible to create and use a thread locally ?!?
My mean is :
procedure Requery;
var
...
begin
Create Thread;
...
Pass my Query Component to Thread
...
Getting Query in Thread;
...
Terminate and Free Thread
...
Do next jobs with Query;
...
end;
The main part is last part ( Do next jobs ... ) , I dont want to use query result in a message handler and I want to use them in the same procedure and after thread job
Is it possible ?!
I think this is not possible with Delphi TThread class and I should use other threading techniques ...
I`m using Delphi XE6
What you describe is not the best use of a thread. The calling code is blocked until the thread is finished. That negates the use of running code in parallel at all. You could just perform the query directly instead:
procedure Requery;
var
...
begin
...
// run query
// do next jobs with query
...
end;
That being said, since you are using XE6, you can create a "local" thread by using the TThread.CreateAnonymousThread() method, specifying an anonymous procedure that "captures" the variables you want it to work with, eg:
procedure Requery;
var
Event: TEvent;
H: THandle;
begin
Event := TEvent.Create;
try
TThread.CreateAnonymousThread(
procedure
begin
try
// run query in thread
finally
Event.SetEvent;
end;
end
).Start;
H := Event.Handle;
while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_ALLINPUT) = (WAIT_OBJECT_0+1) do
Application.ProcessMessages;
finally
Event.Free;
end;
// Do next jobs with query
...
end;
Alternatively:
procedure Requery;
var
Thread: TThread;
H: THandle;
begin
Thread := TThread.CreateAnonymousThread(
procedure
begin
// run query in thread
end
);
try
Thread.FreeOnTerminate := False;
H := Thread.Handle;
Thread.Start;
while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_ALLINPUT) = (WAIT_OBJECT_0+1) do
Application.ProcessMessages;
finally
Thread.Free;
end;
// Do next jobs with query
...
end;
However, threading is more useful when you let it run in the background while you do other things and then you act when the thread has finished its work. For example:
procedure TMyForm.Requery;
var
Thread: TThread;
begin
Thread := TThread.CreateAnonymousThread(
procedure
begin
// run query in thread
end
);
Thread.OnTerminate := QueryFinished;
Thread.Start;
end;
procedure TMyForm.QueryFinished(Sender: TObject);
begin
if TThread(Sender).FatalException <> nil then
begin
// something went wrong
Exit;
end;
// Do next jobs with query
end;
I think that using a thread this way isn't a good idea, but the answer is yes. You can do it.
procedure LocalThread;
var
LThread: TCustomThread; //Your thread class
LThreadResult: xxxxxxx//Your result type
begin
LThread := TCustomThread.Create(True);
try
//Assign your properties
LThread.Start;
//Option A: blocking
LThread.WaitFor;
//Option B: non blocking
while not LThread.Finished do
begin
Sleep(xx);
//Some progress here ??
end;
//Here query your thread for your result property
LThreadResult := LThread.MyResultProperty;
finally
LThread.Free;
end
//Do next jobs with LThreadResult
end;
Yes you can do that.
The way I would do it is to add an event-handler to your form.
You'll have to link the event-handler in code, but that's not that difficult.
Create a thread like so:
TMyEventHandler = procedure(Sender: TObject) of object;
type
TMyThread = class(TThread)
strict private
FDoneEvent: TMyEvent;
FDone: boolean;
FQuery: TFDQuery;
constructor Create(DoneEvent: TMyEventHandler; Query: TFDQuery);
procedure Execute; override;
function GetQuery: TFDQuery;
public
property Query read GetQuery;
end;
TForm1 = class(TForm)
FDQuery1: TFDQuery; //Do not connect the FDQuery1 to anything!
DataSource1: TDataSource;
DBGrid1: TDBGrid;
private
FOnThreadDone: TMyEventHandler;
FMyThread: TMyThread;
procedure DoThreadDone;
procedure ThreadDone;
public
property OnThreadDone: TMyEventHandler read FOnThreadDone write FOnThreadDone;
....
implementation
constructor TMyThread.Create(DoneEvent: TMyEvent; Query: TFDQuery);
begin
inherited Create(true);
FDoneEvent:= DoneEvent;
FQuery:= Query;
Start;
end;
procedure TMyThread.Execute;
begin
//Do whatever with the query
//when done do:
FDone:= true;
Synchonize(Form1.DoThreadDone);
end;
function TMyThread.GetQuery: TFDQuery;
begin
if not Done then Result:= nil else Result:= FQuery;
end;
procedure TForm1.DoThreadDone;
begin
if Assigned(FOnThreadDone) then FOnThreadDone(Self);
end;
procedure TForm1.ThreadDone(Sender: TObject);
begin
ShowMessage('Query is done');
//Now you can display the result of the query, by wiring it
//to a dataset.
MyDataSource1.Dataset:= FMyThread.Query;
FMyThread.Free;
end;
procedure TForm1.StartTheQuery;
begin
OnThreadDone:= Self.ThreadDone;
FMyThread:= TMyThread.Create(OnThreadDone, FDQuery1);
end;
Now the query will run in the background and signal your event handler when it is done. Meanwhile you can do all the mousing around and user interaction you want without having to worry. Note that you cannot use FDQuery1 at all whilst the thread is using it, and you cannot have FDQuery1 wired to a DataSource whilst it's the thread is running with it.
Leave it unwired and wire it in the ThreadDone event handler as shown.
When my main application (Delphi 2009) terminates, I want it to signal my threads (timers, TDataModules with ADO Connections, SMTP etc) to dispose gracefully.
In my main application, I have the following:
try
PostThreadMessage(bpvccMAILER.ThreadID, WM_SYSTEM_CLOSE, self.Handle, 0);
returnMessage := (SysErrorMessage(GetLastError)); //Returns 'The operation completed successfully'
while TRUE do
begin
sleep(1000);
if not (Assigned(bpvccMAILER)) then
begin
bpvccACTIVITY_LOGGER.Write('SHUTDOWN','TBPVCommunicatorGUI.FormClose - All Threads have shut down');
break;
end;
locWaited := locWaited + 10;
end;
except
end;
finally
FreeAndNil(bpvccACTIVITY_LOGGER);
FreeAndNil(bpvccMAILER);
end;
Thread class:
TBPVMailer = class(TThread)
protected
SMTP : TIdSMTP;
interval : Integer;
fMain : Integer;
fMainIsSvc : Boolean;
fTerminated: Boolean;
function SendEmail(AEmail: TEmailObj) : TBPVEmailSendResult;
function doSleep : Boolean;
procedure Write(AStatus, AMessage : String);
procedure FlushQueue();
procedure HandleMessage(var Message : TMessage); message WM_SYSTEM_CLOSE;
public
constructor Create(AServer : String; APort : Integer; AUser, APass : String; AInterval : Integer; StartSuspended : Boolean); overload;
procedure Execute; override;
procedure QueueEmail(AEmail: TEmailObj; EmailType : TBPVEmailType; AssociatedID : String);
destructor Destroy; override;
end;
procedure TBPVMailer.HandleMessage(var Message: TMessage);
var
msg : tagMSG;
begin
PeekMessage(&msg, 0, 0, 0, PM_NOREMOVE);
fMain := Message.WParam;
fMainIsSvc := Message.LParam = 1;
fTerminated := TRUE;
end;
Problem is, Assigned(bpvccMAILER) always returns true even after calling PostThreadMessage. Also, bpvccMAILER.fTerminated is always FALSE, which means the TBPVMailer.HandleMessage is never executed because that is were the value is set to TRUE. What am I doing wrong, it appears that my threads arent receiving the messages?
The obvious explanation is that you don't have a message pump in your thread. You post the message, but the thread does not pump its queue.
The code is needlessly complex though. There seems to be no need for messages at all. Call the Terminate method of the thread and then use its WaitFor method to wait until it stops. Or even simpler, just call Free on the thread.
Your code does contain a number of oddities:
Why do you call PeekMessage? That serves no purpose that I can discern.
Waiting with Sleep should be avoided. You can almost always use dedicated wait functions.
It's odd the you wait until bpvccMAILER is nil, but then use FreeAndNil(bpvccMAILER).
You must only call GetLastError when it is well-defined. Typically that is only when the preceeded API call has failed. And failure is indicated by the value returned by the API call.
The Sleep loop in the main thread is not OK since it blocks processing messages.
Just call the PostThreadMessage and return, without any Sleep loop afterwards.
If you need to wait until bpvccMAILER finishes, add code that on completion send a PostMessage to your main thread. So, the main thread will handle this message and will be aware that the auxiliary thread has finished. It may not be easy to change your application this way straight from the start, but little by little you will be designing applications in such a way that always does correct thread handling.
Besides that, if you use PostThreadMessage, then your Thread.Execute loop must have MsgWaitForMultipleObjects.
Here is an example on how the Thread.Execute loop have to be:
<skipped>
repeat
<skipped>
R := MsgWaitForMultipleObjects(EventCount, EventArray, False, INFINITE, QS_ALLINPUT);
<skipped>
if R = WAIT_OBJECT_0 + EventCount then
begin
while PeekMessage(M, 0, 0, 0, PM_REMOVE) do
begin
if M.Message = WM_QUIT then
Break;
TranslateMessage(M);
DispatchMessage(M);
end;
if M.Message = WM_QUIT then
Break;
end;
<skipped>
until Terminated;
<skipped>
If your application will eventually need to exit while the tread is running (assume your thread object is in T variable), do the following:
T.Terminate;
SetEvent([one of the event of the EventArray]); // we should call it AFTER terminate for the Terminated property would already be True when the tread exits from MsgWaitForMultipleObjects
T.WaitFor;
T.Free; // "Free" calls "WaitFor" anyway, but Remy Lebeau suggests to explicitly call "WaitFor" before "Free".
T := nil;
I've been trying to figure this error our for about 4 days now. I'm using Delphi XE and have created a little tool for translators to use. I got the idea of using the Microsoft Translation API to help make things easier and a bit less tedious.
I created a class that accesses the Microsoft translator API, but I wanted to make it Thread Safe so the requests could be made in the background. I have no problem sending a request to get an Access Token, however, I run that request in a separate thread. When the user clicks a button, I spawn a new thread and run the http request to translate the term from in there. However, it times out every single time. If I run it from the same thread there's no problem.
Here is the method I use for sending the http requests (the THttpCli object that is passed is shared among threads)
function sendHTTPRequest(APost: Boolean; AURI: UTF8string;
AContentType: UTF8string; APostData: UTF8String; AHttpCli: TSSLHttpCli): UTF8string;
var
DataOut: TMemoryStream;
DataIn: TMemoryStream;
lHTMLStream: TStringStream;
lencoding: TUTF8Encoding;
lownClient: boolean;
begin
lownClient := false;
if AHttpCli = nil then
begin
AHttpCli := TSSLHttpCli.Create(nil);
AHttpCli.SslContext := TSSLContext.Create(nil);
with AHttpCli.SslContext do
begin
SSLCipherList := 'ALL:!ADH:RC4+RSA:+SSLv2:#STRENGTH';
SSLVersionMethod := sslV23_CLIENT;
SSLVerifyPeerModes := [SslVerifyMode_PEER]
end;
AHttpCli.MultiThreaded := true;
lownClient := true;
end;
AHttpCli.Accept := 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
if APost then
begin
DataOut := TMemoryStream.Create;
DataOut.Write(APostData[1], Length(APostData));
DataOut.Seek(0, soFromBeginning);
end;
AHttpCli.URL := AURI;
AHttpCli.ContentTypePost := AContentType;
DataIn := TMemoryStream.Create;
if APost then AHttpCli.SendStream := DataOut;
AHttpCli.RcvdStream := DataIn;
try
if apost then
AHttpCli.Post
else
AHttpCli.Get;
lHTMLStream := TStringStream.Create('', TEncoding.UTF8);
lHtmlStream.LoadFromStream(AHttpCli.RcvdStream);
result := lHtmlStream.DataString;
lHtmlStream.Free;
finally
AHttpCli.Close;
AHttpCli.RcvdStream := nil;
AHttpCli.SendStream := nil;
DataIn.Free;
if APost then
DataOut.Free;
if lownClient then
AHttpCli.free;
end;
end;
I suppose the obvious solution is to just have one thread that waits for a signal to execute, but I was hoping to get an explanation as to why the timeout happens. I have no way to explain why the second thread times out and the first does not.
The HTTP component seems to get stuck on the dnslookup. OverbyteICS uses the Windows function WSAAsyncGetHostByName to lookup the name.
Any help is much appreciated
UPDATE May 13, 2013:
So, as it turns out, sharing the THttpCli object among threads seems to be what causes the timeout. The Solution is simply to pass nil into the AHttpCli parameter in my function above.
I'll still accept an answer as to WHY this causes a timeout. As far as I could tell the WSAAsyncGetHostByName method doesn't use any synchronous objects and the other thread was not running at the same time so there shouldn't be anything blocking the threads.
On Windows, OverbyteICS uses WSAAsyncSelect (here) and MsgWaitForMultipleObjects (here) to allow asynchronous notification of the socket events (FD_READ, FD_WRITE, FD_CLOSE and FD_CONNECT). Part of the design of WSAAsyncSelect requires a window that will receive the event messages, and to that end, a control class is registered using RegisterClass here, and an instance created using CreateWindowEx here, both in the call to THttpCli.Create.
This is where the issue arises; as alluded to in the documentation for GetMessage, PeekMessage and PostMessage, the message queue itself is per thread.
I've tested various permutations of each discrete step of the process (listed below) shared between 2 threads, and the only combinations that fail are when the call to CreateWindowEx and MsgWaitForMultipleObjects are performed on different threads, which reinforces the idea that a given message queue can only be accessed on the same thread.
Seemingly, without a rewrite of the OverbyteICS library itself, the only way to use it in a threaded environment is to create the THttpCli instance in the same thread as the subsequent request calls (THttpCli.Get, THttpCli.Post etc).
Appendix
Call to RegisterClass
procedure Up0(S: PState);
var
WndClass: TWndClass;
begin
FillChar(WndClass, SizeOf(TWndClass), 0);
WndClass.lpfnWndProc := #DefWindowProc;
WndClass.hInstance := hInstance;
WndClass.lpszClassName := 'test';
if RegisterClass(WndClass) = 0 then
ExitProcess(GetLastError);
end;
Call to CreateWindowEx
procedure Up1(S: PState);
begin
S.Window := CreateWindowEx(WS_EX_TOOLWINDOW, 'test', '', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
if S.Window = 0 then
ExitProcess(GetLastError);
end;
Call to Ics_socket
procedure Up2(S: PState);
begin
S.Socket := Ics_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if S.Socket = INVALID_SOCKET then
ExitProcess(Ics_WSAGetLastError);
end;
Call to Ics_WSAAsyncSelect
procedure Up3(S: PState);
begin
if Ics_WSAAsyncSelect(S.Socket, S.Window, WM_USER, FD_CONNECT) = SOCKET_ERROR then
ExitProcess(Ics_WSAGetLastError);
end;
Call to Ics_connect
procedure Up4(S: PState);
var
Error: Integer;
Sin: TSockAddrIn;
begin
FillChar(Sin, SizeOf(TSockAddrIn), 0);
Sin.sin_family := AF_INET;
Sin.sin_port := Ics_htons(42);
if Ics_connect(S.Socket, PSockAddr(#Sin)^, SizeOf(TSockAddrIn)) = SOCKET_ERROR then
begin
Error := Ics_WSAGetLastError;
if Error <> WSAEWOULDBLOCK then
ExitProcess(Error);
end;
end;
Call to MsgWaitForMultipleObjects
procedure Up5(S: PState);
var
Msg: TMsg;
WaitResult: Cardinal;
begin
WaitResult := MsgWaitForMultipleObjects(0, Pointer(nil)^, False, 1000, QS_ALLINPUT);
if WaitResult = WAIT_TIMEOUT then
begin
S.Result := 0;
Exit;
end;
while PeekMessage(Msg, S.Window, WM_USER, WM_USER, PM_REMOVE) do
if LOWORD(Msg.lParam) = FD_CONNECT then
begin
S.Result := 1;
Exit;
end;
end;