I have this code inside thread and when I call terminate it terminates fast if it is not in the middle of http request , but when I have 20 threads it takes time to finish http request and exit the thread.
CODE:
procedure TParser.Execute;
var
i,b:integer;
t:string;
begin
http := thttpsend.create;
http.KeepAlive:=true;
Ftest:=TStringList.Create;
{http.timeout:=5000;}
for i:=0 to FStartNum.Count do
if FLocalVariable<FStartNum.Count-FThreadCount then
begin
if terminated then begin
exit;
end
else
EnterCriticalSection(Form1.StringSection);
try
FLocalVariable := form1.GlobalVariable;
Inc(FLocalVariable);
form1.GlobalVariable := FLocalVariable;
finally
LeaveCriticalSection(Form1.StringSection);
http.Clear;
HTTP.HTTPMethod('GET',FStartNum.Strings[FLocalVariable]);
Ftest.LoadFromStream(HTTP.Document);
Synchronize(progress);
parse;
Ftest.Clear;
end;
end;
end;
How do I stop this HTTP request from main form :
HTTP.HTTPMethod('GET',FStartNum.Strings[FLocalVariable]);
Ftest.LoadFromStream(HTTP.Document);
Thanks
Edit: Termination code :
for i:=Low(fparser) to High(fparser) do
begin
Fparser[i].Terminate();
end;
Call the THttpSend.Abort() method to stop a transfer that is in progress. You can do that in the THttpSend.OnStatus event, eg:
procedure TParser.Execute;
var
...
begin
http := THttpSend.Create;
http.OnStatus := HttpStatus;
...
end;
procedure TParser.HttpStatus(Sender: TObject; Reason: THookSocketReason; const Value: String);
begin
if Terminated then Http.Abort;
end;
Related
I was unable to follow how it is working.
A very simple example first, to try explain my situation better.
This code is inside a new Form Form1 create in a new project. Where mmo1 is a Memo component.
TOb = class
Name : String;
constructor Create(Name : String);
procedure Go();
end;
procedure TOb.Go;
begin
Form1.mmo1.Lines.Add(Name);
end;
Then I have a button with this event:
procedure TForm1.btn4Click(Sender: TObject);
var
Index : Integer;
begin
mmo1.Lines.Clear;
for Index := 1 to 3 do
TThread.CreateAnonymousThread(TOb.Create('Thread ' + IntToStr(Index)).Go).Start;
end;
And my output on the memo is:
Thread 4
Thread 4
Thread 4
I really don't got it.
First question: Why the "Name" output is: Thread 4? Is a For loop from 1 to 3. At least should be 1 or 3
Second: Why it only execute the last thread "Thread 4", instead of 3 times in sequence "Thread 1", "Thread 2", "Thread 3"?
Why I'm asking this? I have an object that has already a process working fine. But now I found me in a situation that I need a List of this object to be processed. Sure work fine process one by one, but in my case they are independent one of other so I thought "hm, lets put them in threads, so it will run faster".
To avoid modifying the object to extend TThread and overriding Execute I look up on how to execute a thread with a procedure instead of an object that inherits from TThread and found the Anonymous Thread. Works really great with one object, but when I tried loop through my object list, strange behaviors happens.
This has the same effect.
for Index := 1 to 3 do
TThread.CreateAnonymousThread(
procedure
var
Ob : TOb;
begin
OB := TOb.Create('Thread ' + IntToStr(Index));
OB.Go;
end
).Start;
Sure I'm not clean the object, this was just some tests that I was running.
Any Ideas? Or in this case I will need to inherits from TThread and override the Execute methode?
The funny thing is that THIS runs just fine.
mmo1.Lines.Clear;
TThread.CreateAnonymousThread(TOb.Create('Thread ' + IntToStr(1)).Go).Start;
TThread.CreateAnonymousThread(TOb.Create('Thread ' + IntToStr(2)).Go).Start;
TThread.CreateAnonymousThread(TOb.Create('Thread ' + IntToStr(3)).Go).Start;
Output:
Thread 1
Thread 2
Thread 3
Works really great with one object, but when I tried loop through my object list, strange behaviors happens.
You are likely not taking into account how anonymous procedures bind to variables. In particular:
Note that variable capture captures variables--not values. If a variable's value changes after being captured by constructing an anonymous method, the value of the variable the anonymous method captured changes too, because they are the same variable with the same storage. Captured variables are stored on the heap, not the stack.
For example, if you do something like this:
var
Index: Integer;
begin
for Index := 0 to ObjList.Count-1 do
TThread.CreateAnonymousThread(TOb(ObjList[Index]).Go).Start;
end;
You will actually cause an EListError exception in the threads (I least when I tested it - I don't know why it happens. Verified by assigning an OnTerminate handler to the threads before calling Start(), and then having that handler check the TThread(Sender).FatalException property).
If you do this instead:
var
Index: Integer;
Ob: TOb;
begin
for Index := 0 to ObjList.Count-1 do
begin
Ob := TOb(ObjList[Index]);
TThread.CreateAnonymousThread(Ob.Go).Start;
end;
end;
The threads won't crash anymore, but they are likely to operate on the same TOb object, because CreateAnonymousThread() is taking a reference to the TOb.Go() method itself, and then your loop is modifying that reference's Self pointer on each iteration. I suspect the compiler is likely generating code similar to this:
var
Index: Integer;
Ob: TOb;
Proc: TProc; // <-- silently added
begin
for Index := 0 to ObjList.Count-1 do
begin
Ob := TOb(ObjList[Index]);
Proc := Ob.Go; // <-- silently added
TThread.CreateAnonymousThread(Proc).Start;
end;
end;
If you do this instead, it will have a similar issue:
procedure StartThread(Proc: TProc);
begin
TThread.CreateAnonymousThread(Proc).Start;
end;
...
var
Index: Integer;
Ob: TOb;
begin
for Index := 0 to ObjList.Count-1 do
begin
Ob := TOb(ObjList[Index]);
StartThread(Ob.Go);
end;
end;
Probably because the compiler generates code similar to this:
procedure StartThread(Proc: TProc);
begin
TThread.CreateAnonymousThread(Proc).Start;
end;
...
var
Index: Integer;
Ob: TOb;
Proc: TProc; // <--
begin
for Index := 0 to ObjList.Count-1 do
begin
Ob := TOb(ObjList[Index]);
Proc := Ob.Go; // <--
StartThread(Proc);
end;
end;
This will work fine, though:
procedure StartThread(Ob: TOb);
begin
TThread.CreateAnonymousThread(Ob.Go).Start;
end;
...
var
Index: Integer;
Ob: TOb;
begin
for Index := 0 to ObjList.Count-1 do
begin
Ob := TOb(ObjList[Index]);
StartThread(Ob);
// or just: StartThread(TOb(ObjList[Index]));
end;
end;
By moving the call to CreateAnonymousThread() into a separate procedure that isolates the actual reference to TOb.Go() into a local variable, you remove any chance of conflict in capturing the reference for multiple objects.
Anonymous procedures are funny that way. You have to be careful with how they capture variables.
After reading a the article that Remy Lebeau post on the comments, I found this solution.
changing the main object by add one more procedure that make the call.
Change the loop instead of creating the anonymous thread at the main loop, it is created inside the object.
TOb = class
Name : String;
constructor Create(Name : String);
procedure Process();
procedure DoWork();
end;
procedure TOb.Process;
begin
TThread.CreateAnonymousThread(DoWork).Start;
end;
procedure TOb.DoWork;
var
List : TStringList;
begin
List := TStringList.Create;
List.Add('I am ' + Name);
List.Add(DateTimeToStr(Now));
List.SaveToFile('D:\file_' + Name + '.txt');
List.Free;
end;
And the loop:
List := TObjectList<TOb>.Create();
List.Add(TOb.Create('Thread_A'));
List.Add(TOb.Create('Thread_B'));
List.Add(TOb.Create('Thread_C'));
List.Add(TOb.Create('Thread_D'));
for Obj in List do
//TThread.CreateAnonymousThread(Obj.Go).Start;
Obj.Process;
Thats resolves the problem with just a minimum change on the Main Object.
This about race condition. When you increased to max value to 100, you will see different values. Threading not guarantee when Thread starts or ends.
You can try this code block.
for I := 1 to 100 do
begin
TThread.CreateAnonymousThread(
procedure
var
Msg : string;
begin
try
Msg := 'This' + I.ToString;
MessageDlg(Msg,mtCustom,
[mbYes,mbAll,mbCancel], 0);
Except
on E: Exception do
End;
end
).Start;
end;
If you want a guarantee to write 1 to 4, you should instantiate every value before send to Thread.
for I := 1 to 100 do
begin
TThread.CreateAnonymousThread(
procedure
var
Msg : string;
begin
var instanceValue := I;
try
Msg := 'This' + instanceValue.ToString;
MessageDlg(Msg,mtCustom,
[mbYes,mbAll,mbCancel], 0);
Except
on E: Exception do
End;
end
).Start;
end;
I've build a datasnap server application for handling data between a windows application and mobile apps.
One method can take a while, and I want to be able to stop it after a certain time(Timeout).
How can I achieve this?
The code below shows one way to provide a server method with timeout behaviour.
The task which may take too long is executed in a secondary thread which is
started in the server method. This method uses a TSimpleEvent object (see the online help) to enable the
secondary thread to signal back to the server method's thread that it has completed. The value (in milliseconds) you specify in the call to Event.WaitFor defines how long to wait before the call times out.
If the call to WaitFor on the SimpleEvent times out, you can take whatever action you
like to notify the server's client. If the call to WaitFor returns wsSignaled, that means that the DBThread must have called SetEvent on the Event object before the period specified when calling WaitFor expired.
Btw, this example was written for D7, so might require minor adaptation for
Seattle. Also it uses a TForm descendant as the "server", but should work equally well in a DataSnap server method, since the principle is the same.
It doesn't address the issue of how exactly to stop whatever task you kick off in the secondary thread, because whether that is possible and how to do it if it is depends on exactly what the task is. Because of that, and the fact that you probably wouldn't want to delay the server method by waiting for the DBThread to complete, it does not attempt to free the DBThread, though in the real world that should of course be done.
type
TServer = class;
TDBThread = class(TThread)
private
FServer: TServer;
FEvent: TSimpleEvent;
FCancelled : Boolean;
function GetCancelled: Boolean;
procedure SetCancelled(const Value: Boolean);
public
procedure Execute; override;
constructor Create(AServer : TServer);
property Server : TServer read FServer;
property Event : TSimpleEvent read FEvent;
property Cancelled : Boolean read GetCancelled write SetCancelled;
end;
TServer = class(TForm)
// ignore the fact that in this case, TServer is a descendant of TForm
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
CS : TCriticalSection;
Event : TSimpleEvent;
public
procedure DoServerMethod;
end;
[...]
{ TDBThread }
constructor TDBThread.Create(AServer: TServer);
begin
inherited Create(True); // create suspended
FreeOnTerminate := False;
FServer := AServer;
FEvent := FServer.Event;
end;
procedure TDBThread.Execute;
var
StartTime : Cardinal;
begin
Cancelled := False;
// Following is for illustration ONLY, to simulate a process which takes time.
// Do not call Sleep() in a loop in a real thread
StartTime := GetTickCount;
repeat
Sleep(100);
until GetTickCount - StartTime > 5000;
if not Cancelled then begin
{ TODO : Transfer result back to server thread }
Event.SetEvent;
end;
end;
function TDBThread.GetCancelled: Boolean;
begin
FServer.CS.Enter;
try
Result := FCancelled;
finally
FServer.CS.Leave;
end;
end;
procedure TDBThread.SetCancelled(const Value: Boolean);
begin
FServer.CS.Enter;
try
FCancelled := Value;
finally
FServer.CS.Leave;
end;
end;
procedure TServer.DoServerMethod;
var
DBThread : TDBThread;
WaitResult : TWaitResult;
begin
DBThread := TDBThread.Create(Self);
DBThread.Resume;
WaitResult := Event.WaitFor(1000);
case WaitResult of
wrSignaled : begin
// the DBThread completed
ShowMessage('DBThread completed');
end;
wrTimeOut : begin
// the DBThread time out
DBThread.Cancelled := True;
ShowMessage('DBThread timed out');
// Maybe use PostThreadMessage here to tell the DBThread to abort (if possible)
// whatever task it is doing that has taken too long.
end;
end; {case}
{ TODO : Terminate and dispose of the DBThread }
end;
procedure TServer.FormCreate(Sender: TObject);
begin
CS := TCriticalSection.Create;
Event := TSimpleEvent.Create;
end;
procedure TServer.Button1Click(Sender: TObject);
begin
DoServerMethod;
end;
How I can save the content of Listbox to file When the computer shutting down or sleeping, or restarting ???
I use Delphi XE7 ,
I do save the file , and I have no problem with it !
but I want to save the file when computer shutting down .
update my code and Problem:
my problem which is , when my project run in the background the both events OnClose & OnDestroy dose not work!
If the project work normally "not in the background", the both event's is work fine!
I figure my problem , which is my project working in background process , i add this lines to do this Application.MainFormOnTaskbar := False; Application.ShowMainForm := False; If i make my project to run in back ground process the events onClose and onDestroy is definitely not work,
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
str :TStringList;
i : integer;
begin
str := TStringList.Create;
for i := 0 to ListBox1.Count-1 do
str.Add(ListBox1.Items.Strings[i]);
try
str.SaveToFile('D:\test1.txt', TEncoding.UTF8);
finally
str.Free;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
str :TStringList;
i : integer;
begin
str := TStringList.Create;
for i := 0 to ListBox1.Count-1 do
str.Add(ListBox1.Items.Strings[i]);
try
str.SaveToFile('D:\test15.txt', TEncoding.UTF8);
finally
str.Free;
end;
end;
Handle the WM_ENDSESSION message and save your file there.
Catch the windows message like this:
private
procedure OnShutDown(var Msg: TMessage); message WM_ENDSESSION;
And here is your implementation
procedure TForm1.OnShutDown(var Msg: TMessage);
begin
//Save your file here.
end;
In order to learn multithreading, I've created a thread inside a COM Thread (TRemoteDataModule).
This is my Component Factory:
TComponentFactory.Create(ComServer, TServerConn2, Class_ServerConn2, ciMultiInstance, tmApartment);
Inside the Thread, I didn't needed to Call CoInitialize to use TADOQuery.Create, .Open... .Exec
I read that I need to initialize the COM library on a thread before you call any of the library functions except CoGetMalloc, to get a pointer to the standard allocator, and the memory allocation functions.
But in this case, the absence of CoInitialize didn't brought me any trouble.
Is this related with Thread Model?
Where can I Find the explanation for this subject?
UPDATE:
When I say INSIDE, it means inside the COM method context:
interface
type
TWorker = class(TThread);
TServerConn2 = class(TRemoteDataModule, IServerConn2)
public
procedure Method(); safecall;
end;
implementation
procedure TServerConn2.Method();
var W: TWorker;
begin
W := TWorkerTread.Create(Self);
end;
UPDATE 2:
The TADOConnection used to connect to database are currently being created in the COM Thread context (TThread.Create constructor). Although, TADOConnection.Open and TADOQuery.Create/.Open are both being performed inside TThread.Execute .
UPDATE 3 - Simulacrum
Interface:
type
TServerConn2 = class;
TWorker = class(TThread)
private
FDB: TADOConnection;
FOwner: TServerConn2;
protected
procedure Execute; override;
public
constructor Create(Owner: TServerConn2);
destructor Destroy; override;
end;
TServerConn2 = class(TRemoteDataModule, IServerConn2)
ADOConnection1: TADOConnection;
procedure RemoteDataModuleCreate(Sender: TObject);
private
{ Private declarations }
protected
class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
procedure CheckException; safecall;
public
User, Pswd, Str: String;
Ok: Boolean;
end;
Implementation:
class procedure TServerConn2.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
if Register then
begin
inherited UpdateRegistry(Register, ClassID, ProgID);
EnableSocketTransport(ClassID);
EnableWebTransport(ClassID);
end else
begin
DisableSocketTransport(ClassID);
DisableWebTransport(ClassID);
inherited UpdateRegistry(Register, ClassID, ProgID);
end;
end;
{ TWorker }
constructor TWorker.Create(Owner: TServerConn2);
begin
inherited Create(False);
FreeOnTerminate := True;
FDB := TADOConnection.Create(nil);
FOwner := Owner;
end;
destructor TWorker.Destroy;
begin
FDB.Free;
FOwner.Ok := True;
inherited;
end;
procedure TWorker.Execute;
var Qry: TADOQuery;
begin
FDB.LoginPrompt := False;
FDB.ConnectionString := FOwner.Str;
FDB.Open(FOwner.User, FOwner.Pswd);
Qry := TADOQuery.Create(nil);
try
Qry.Connection := FDB;
Qry.LockType := ltReadOnly;
Qry.SQL.Text := 'SELECT TOP 1 * FROM MyTable';
Qry.Open;
finally
Qry.Free;
end;
end;
procedure TServerConn2.CheckException;
var W: TWorker;
begin
W := TWorker.Create(Self);
while not Ok do Sleep(100);
end;
procedure TServerConn2.RemoteDataModuleCreate(Sender: TObject);
begin
User := 'user';
Pswd := 'pass';
Str := ADOConnection1.ConnectionString;
end;
initialization
TComponentFactory.Create(ComServer, TServerConn2,
Class_ServerConn2, ciMultiInstance, tmApartment);
end.
UPDATE 4
The error should happen here:
function CreateADOObject(const ClassID: TGUID): IUnknown;
var
Status: HResult;
FPUControlWord: Word;
begin
asm
FNSTCW FPUControlWord
end;
Status := CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IUnknown, Result);
asm
FNCLEX
FLDCW FPUControlWord
end;
if (Status = REGDB_E_CLASSNOTREG) then
raise Exception.CreateRes(#SADOCreateError) else
OleCheck(Status);
end;
By somehow (because of TComponentFactory maybe?) CoCreateInstance identifies that TWorker is in the same context than TServerConn2 and don't raise errors?
Either or both of the following might apply:
On a thread not initialized with COM all existing interface pointers keep working until you make a COM API call or otherwise require COM marshalling which then fails detecting an uninitialized thread. That is, your "didn't brought me any trouble" might actually be too early to say.
If any thread in the process calls CoInitialize[Ex] with the COINIT_MULTITHREADED flag, then that not only initializes the current thread as a member of the multi-threaded apartment, but it also says, "Any thread which has never called CoInitialize[Ex] is also part of the multi-threaded apartment." - so called impicit MTA thing
The TADOConnection used to connect to database are currently being created in the COM Thread context (TThread.Create constructor). Although, TADOConnection.Open and TADOQuery.Create/.Open are both being performed inside TThread.Execute .
That will not work, for 2 reasons:
TWorker.Create() and TWorker.Execute() will run in different thread contexts. Create() will run in the context of the thread that is calling TServerConn2.CheckException() (which will have already called CoInitialize/Ex() on itself beforehand), but Execute() will run in the context of the TThread thread instead. ADO is apartment threaded, which means its COM interfaces cannot be used across thread/apartment boundaries unless you marshal them, either via the IGlobalInterfaceTable interface or the CoMarshalInterThreadInterfaceInStream() and CoGetInterfaceAndReleaseStream() functions.
even if you did marshal the ADO interfaces, TWorker.Execute() must call CoInitialize/Ex() on itself. EVERY individual thread must initialize COM to establish its threading model before then accessing any COM interfaces. The threading model dictates how COM accesses interfaces (direct or through proxies), whether message queues are used, etc.
So the simple solution to your problem is to NOT create and use the ADO components across thread boundaries at all. Move your TADOConnection into Execute() instead:
constructor TWorker.Create(Owner: TServerConn2);
begin
inherited Create(False);
FreeOnTerminate := True;
FOwner := Owner;
end;
destructor TWorker.Destroy;
begin
FOwner.Ok := True;
inherited;
end;
procedure TWorker.Execute;
var
DB: TADOConnection;
Qry: TADOQuery;
begin
CoInitialize;
try
DB := TADOConnection.Create(nil);
try
DB.LoginPrompt := False;
DB.ConnectionString := FOwner.Str;
DB.Open(FOwner.User, FOwner.Pswd);
Qry := TADOQuery.Create(nil);
try
Qry.Connection := DB;
Qry.LockType := ltReadOnly;
Qry.SQL.Text := 'SELECT TOP 1 * FROM MyTable';
Qry.Open;
finally
Qry.Free;
end;
finally
DB.Free;
end;
finally
CoUninitialize;
end;
end;
When you create an apartment thread using TComponentFactory it calls CoInitialize and CoUnInitialize for you - it's right in the VCL source (System.Win.VCLCom.pas):
procedure TApartmentThread.Execute;
var
msg: TMsg;
Unk: IUnknown;
begin
try
CoInitialize(nil); // *** HERE
try
FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
FUnkOuter := nil;
FFactory := nil;
if FCreateResult = S_OK then
CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
ReleaseSemaphore(FSemaphore, 1, nil);
if FCreateResult = S_OK then
while GetMessage(msg, 0, 0, 0) do
begin
DispatchMessage(msg);
Unk._AddRef;
if Unk._Release = 1 then break;
end;
finally
Unk := nil;
CoUninitialize; // ** AND HERE
end;
except
{ No exceptions should go unhandled }
end;
end;
I am trying out following code. However, if I click on form's close button while this code is running, nothing happens. How can I correct this? I need to close the form even when this loop is executing.
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
end;
end;
Have a look at what's going on inside Application.ProcessMessages.
When you close the main form, windows sends a WM_QUIT message to the program. The relevant part of TApplication.ProcessMessages looks like this:
if Msg.Message <> WM_QUIT then
begin
//skipped
end
else
begin
{$IF DEFINED(CLR)}
if Assigned(FOnShutDown) then FOnShutDown(self);
DoneApplication;
{$IFEND}
FTerminate := True;
end;
I assume this is not a CLR program, so the only thing that happens at this point is setting FTerminate := True on Application. This is reflected in the Application.Terminated property.
When the application shuts down, one of the things it does in order to shut down safely is wait for all threads to finish. This code happens to be running in the main thread, but the principle would be the same in any thread: If you're doing a long-running task that might have to finish early, you have to explicitly check for early termination.
Knowing this, it's easy to figure out how to fix your code:
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then
Break;
end;
end;
Also, beware of using Application.ProcessMessages in the first place, as it will process all messages for the application. For a simple idea of what might go wrong, try adding IntToStr(i) instead of 'hi' to Memo1.Lines, knock a couple of orders of magnitude off the counter, and then click the button two or three times in rapid succession and watch the output...
Check for Apllication Terminated:
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
You need to run any tight loop in a thread. This will solve the problem.
BUT if you want to keep the code as it is, Application.ProcessMessages will make your loop terribly slow. So you need to run Application.ProcessMessages not so often:
Counter:= 0;
for i := 0 to 9999999 do
begin
DoSomeStuff;
{ Prevent freeze }
inc(Counter);
if counter > 10000 then
begin
Counter:= 0;
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
end;