I'm using OTL, pipelines tasks to check a bunch of URLs. My question is: How to restart the search again quickly, I mean it takes time to add the strings again to Pipeline input and start again, is there a way to do that? If not? Am I using the wrong OTL pattern? my app is just a simple checker with 1 pipeline stage.
Thank You.
type
...
Private
FInProcess: Boolean;
procedure SetInProcess(const Value: Boolean);
property inProcess: Boolean read FInProcess write SetInProcess;
...
var U,zz : string;
begin
if Value = InProcess then exit;
FInProcess := Value;
if Value then
Timer1.Enabled := Value;
If not Value then
FlushData; //take pipeline output to Form1
If not Value then
pipeline := nil;
If not Value then
begin // this how i restart checking
if CheckBox3.Checked = True then
begin
LChecker := TstringList.Create;
zz := ExtractFilePath(ParamStr(0)) + 'Checker.txt';
LChecker.LoadFromFile(zz);
pipeline := Parallel.Pipeline;
pipeline.Stage(Retriever).NumTasks(60).Run;
try
for U in LChecker do
pipeline.Input.Add(U);
pipeline.Input.CompleteAdding;
finally
LChecker.Free;
end;
inProcess := True;
end else
ShowMessage('Checking Complete');
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
pipeline := Parallel.Pipeline;
pipeline.Stage(Retriever).NumTasks(60).Run;
try
for U in LChecker do //chars : StringList
pipeline.Input.Add(U);
pipeline.Input.CompleteAdding;
finally
LChecker.Free;
end;
inProcess := True;
end;
Related
how to stop Pipleline tasks correctly, I've tried but when i press Abort button i get an AV, i'm not too good at debugging,i have reached to DoOnStop(task); in OtlParallel then i couldn't figure out what to do next, i believe there is something missing ?
type
procedure SetInProcess(const Value: Boolean);
private
FInProcess: Boolean;
property inProcess: Boolean read FInProcess write SetInProcess;
public
FStopAll: Boolean;
procedure FlushData;
procedure Retriever(const input: TOmniValue; var output: TOmniValue);
...
procedure TForm1.SetInProcess(const Value: Boolean);
var
I: Integer;
begin
if Value = InProcess then exit;
memo1.ReadOnly := Value;
FInProcess := Value;
if Value then
Memo1.Lines.Clear;
Timer1.Enabled := Value;
If not Value then
begin
FlushData;
pipeline := nil;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
If not InProcess then exit;
FlushData;
if Pipeline.Output.IsFinalized then
InProcess := False;
end;
procedure TForm1.StartButton(Sender: TObject);
var
i : integer;
urlList : TStrings;
U, S : string;
value : TOmniValue;
begin
urlList := Memo2.Lines;
pipeline := Parallel.Pipeline;
pipeline.Stage(Retriver).NumTasks(StrToInt(Edit12.Text)).Run;
for U in urlList do
pipeline.Input.Add(U);
pipeline.Input.CompleteAdding;
inProcess := True;
end;
procedure TForm1.FlushData;
var v: TOmniValue;
begin
if pipeline = nil then exit;
if pipeline.Output = nil then exit;
Memo1.Lines.BeginUpdate;
try
while pipeline.Output.TryTake(v) do
Memo1.Lines.Add(v.AsString);
if FStopAll then
begin
Pipeline.Cancel;
end;
Memo1.Lines.EndUpdate;
except
on E: Exception do
begin
Memo1.Lines.Add(E.Message);
end;
end;
Memo1.Lines.EndUpdate;
end;
procedure TForm1.Retriver(const input: TOmniValue; var output: TOmniValue);
var
lHTTP : TIdHTTP;
Params : TStrings;
Reply,String1,String2 : string;
begin
X := Input.AsString;
Params := TStringList.Create;
string1 := Extract1(X);
string2 := Extract2(X);;
Params.Add('username=' + string1);
Params.Add('password=' + string2);
lHTTP := TIdHTTP.Create(nil);
try
...
Reply := lHTTP.Post('https://www.instagram.com/accounts/login/ajax/', Params);
if AnsiContainsStr(Reply, 'no')
then
begin
Alive.Add(string1+string2+' Client ok'); ///Alive is Global Var stringlist created earlier
end;
except
on E: EIdHTTPProtocolException do
Exit
end;
lHTTP.Free;
end;
procedure TForm1.AbortButton(Sender: TObject);
begin
try
FStopAll := False;
finally
FStopAll := True;
end;
end;
In your case of over-simplified one-stage pipeline suffice would be moving check into the worker stage itself.
procedure Retriever(const input: TOmniValue; var output: TOmniValue);
var
....
begin
if FStopAll then exit;
X := Input.AsString;
....
PS. I want to repeat that your code leaks memory badly, and that you ignored all my notes I stated before.
PPS. This code not also makes little sense (there is not point in flip-vloppign the variable to one value then to another) but is syntactically incorrect and would not compile. Thus it is not the same code you actually run. It is some different code.
procedure TForm1.AbortButton(Sender: TObject);
begin
try
FStopAll := False;
finally
FStopAll := True;
end;
end;
i am new to Threads, i have a List contains a strings. My goal is to make multiple threads do work to this List, this codes only for a single thread because i'm learning currently, however i get AV when i press start Button.
type
TDemoThread = class(TThread)
private
procedure Abort;
protected
procedure Execute; override;
public
List: TStringList;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
var
i: integer;
List: Tstrings;
begin
for i := 0 to memo1.Lines.Count - 1 do
begin
List := TStringList.Create;
List.Add(memo1.Lines.Strings[i]);
end;
Thread := TDemoThread.Create(True);
Thread.FreeOnTerminate := True;
Thread.Start;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
X: Tstrings;
begin
inherited;
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
X := TStringList.Create;
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to List.Count - 1 do
try
X.Text := lHTTP.Get('https://instagram.com/' + List.Strings[i]);
S := ExtractDelimitedString(X.Text);
X.Clear;
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(List.Strings[i] + ' : ' + S);
end);
finally
end;
end;
Your problem is that you never assign to the List member of the thread class:
type
TDemoThread = class(TThread)
private
procedure Abort;
protected
procedure Execute; override;
public
List: TStringList; <-- never assigned to, hence always nil
end;
Hence the access violation.
It looks like you are trying to pass the contents of memo1 to the thread. I would do that like so:
type
TDemoThread = class(TThread)
private
FData: TStringList;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
end;
constructor TDemoThread.Create(Data: TStrings);
begin
inherited Create(False);
FData := TStringList.Create;
FData.Assign(Data);
FreeOnTerminate := True;
end;
destructor TDemoThread.Destroy;
begin
FData.Free;
inherited;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
X: TStrings;
begin
inherited;
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
X := TStringList.Create;
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to FData.Count - 1 do
try
X.Text := lHTTP.Get('https://instagram.com/' + FData[i]);
S := ExtractDelimitedString(X.Text);
X.Clear;
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(FData[i] + ' : ' + S);
end);
finally
end;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
begin
TDemoThread.Create(memo1.Lines);
end;
It is pointless to create suspended and then immediately start. It is also not permitted to hold a reference to a FreeOnTerminate thread after it has started so I removed that.
The code in TDemoThread.Execute leaks, unless you are running exclusively on an ARC platform. And the try/finally is pointless. And you don't need a string list to hold a single string. Assuming you aren't using ARC it should be:
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
S: string;
begin
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
try
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to FData.Count - 1 do
begin
S := ExtractDelimitedString(lHTTP.Get('https://instagram.com/' + FData[i]));
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(FData[i] + ' : ' + S);
end);
end;
finally
lHTTP.Free;
end;
end;
Personally I'd avoid updating the form from the threads themselves. Threads are data generators here, not GUI managers. So let them separate their concerns.
I'd make all the threads accumulate the results into the same shared container and then make a GUI thread to poll that container instead. Human eyes are slow and Windows GUI is slow too, so you should not update your GUI more often than 2 or 3 times per second. It would only waste CPU load and blur the form into being unreadable.
Another thing would be to avoid using slow TStringList unless its extra functionality (which makes it slow) is required. The regular TList<string> is more than enough as a dumb container and is faster.
type
TDemoThread = class;
TfrmMain = class(TForm)
private
Fetchers: TThreadList<TDemoThread>;
Data: TThreadList<string>;
property inProcess: Boolean read ... write SetInProcess;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
....
end;
// this demo makes each thread per each line - that is actually a bad design
// one better use a thread pool working over the same queue and only have
// 20-40 worker threads for all the URLs
TDemoThread = class(TThread)
private
URL: string;
List: TThreadList<string>;
Tracker: TThreadList<TDemoThread>;
protected
procedure Execute; override;
end;
procedure TfrmMain.BeforeDestruction;
begin
while TThreadList.Count > 0 do
Sleep(100);
FreeAndNil( Fetchers );
Data.Free;
inherited;
end;
procedure TfrmMain.AfterConstruction;
begin
Fetchers := TThreadList<TDemoThread>.Create;
Data := TThreadList<string>.Create;
inherited;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
var
i: integer;
List: Tstrings;
worker: TDemoThread;
URL: string;
begin
If inProcess then exit;
for URL in memo1.Lines do begin
worker := TDemoThread.Create(True);
worker.FreeOnTerminate := True;
worker.URL := URL;
worker.List := Data;
worker.Tracker := Fetchers;
Fetchers.Add( worker );
end;
InProcess := True;
for worker in Fetchers do
worker.Start;
end;
procedure TfrmMain.SetInProcess(const Value: Boolean);
begin
if Value = InProcess then exit; // form already is in this mode
FInProcess := Value;
memo1.ReadOnly := Value;
StartButton.Enabled := not Value;
if Value then begin
Memo2.Lines.Clear;
Data.Clear;
end;
Timer1.Delay := 500; // twice per second
Timer1.Enabled := Value;
If not Value then // for future optimisation - make immediate mode change
FlushData; // when last worker thread quits, no waiting for timer event
If not Value then
ShowMessage('Work complete');
end;
procedure TfrmMain.Timer1Timer(const Sender: TObject);
begin
FlushData;
if Fetchers.Count <= 0 then
InProcess := False;
end;
procedure TfrmMain.FlushData;
begin
Data.LockList; // next two operations should go as non-interruptible atom
try
Memo2.Lines.AddStrings( Data.ToArray() );
Data.Clear;
finally
Data.UnLockList;
end;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
begin
try
lHTTP := TIdHTTP.Create(nil);
try
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
S := ExtractDelimitedString( lHTTP.Get('https://instagram.com/' + URL) );
List.Add( S );
finally
lHTTP.Destroy;
end;
finally
Tracker.Remove( Self );
end;
end;
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TThreadList
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TStrings.AddStrings
PS. Personally, I'd also use OmniThreads Library, as it generally makes maintaining data-generating threads easier. For example just managing how many threads did you created becomes setting one property and determining when all threads complete their work is another oneliner. You really should not create a thousand of threads to fetch all the URLs, instead you should have 10-20 threads in a Thread Pool that would take the URLs from a Input Queue and fetch them one after another. I suggest you reading about OTL's Parallel For and Fork-Join patterns at http://otl.17slon.com/tutorials.htm - it would allow making such an application more concise and easier to write. Pipeline pattern would probably be even better match for this task - since you anyway prepare URLs list as a source collection. Half the scaffolding in StartButtonClick would be gone, and the whole TDemoThread class too.
UPDATE Problem Still Exists.
Is it possible to run code in already running thread? for example:
thread1 is running some code & i want to run code from thread2 in thread1.
I want to run code in idTCPServer thread to send some data to client
Edit:
After research seems that my problem is that when Client data is received or is receiving same time another thread is trying to write to that socket.
Edit:
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
begin
// Application.ProcessMessages;
Command := AContext.Connection.Socket.ReadLn;
// messagebox(0,'snd','',$40);
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then // keepalive
begin
//Application.ProcessMessages;
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
procedure Client_ProcessData(AContext: TIdContext; cmd : String; data : TMemoryStream);
var
Hnd : THandle;
clData : TStringArray;
TmpStr1 : String;
Tmp : String;
TN : TIdNotify;
Sync : TMySync;
I,I2 : Integer;
begin
Hnd := AContext.Connection.Socket.Binding.Handle;
if cmd = 'scr' then // RECEIVE COMMAND TO SEND TO CLIENT TO RECEIVE DATA FROM CLIENT
begin
Tmp := StreamToString(data);
{Sync := TMySync2.Create(True);
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.tmp := TmpStr1;
Sync.Resume;
finally
//Sync.Free;
end; }
log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::');
// SendCMDToSocket(MainFrm.UserSRV,StrToInt(Trim(Tmp)),'scr'+IntToStr(Hnd));
I2 := StrToInt(Trim(Tmp));
for I := 0 to 100 do
if USRVData[i].hnd = I2 then
begin
// cs.Acquire;
USRVData[i].CTX.Connection.Socket.WriteLn('scr'+IntToStr(Hnd)); // PLACED ALL CONTEXTs IN GLOBAL VARIABLE + ALL SOCKET HANDLES. <--- HERE IS THE PROBLEM
// cs.Release;
Break;
end;
// log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::'+streamtostring(data));
Exit;
end;
if Copy(cmd,1,Length('scr4u')) = 'scr4u' then // RECEIVE DATA FROM CLIENT TO SEND IT TO ADMIN CLIENT REQUEST ABOVE
begin
if Length(cmd) > Length('scr4u') then
begin
Delete(cmd,1,Length('scr4u'));
Data.Position := 0;
{ Sync := TMySync.Create;
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.data := TMemoryStream.Create;
Sync.data.CopyFrom(data,data.Size);
Sync.data.Position := 0;
Sync.DoNotify;
finally
Sync.data.Free;
Sync.Free;
end; }
SendStreamToSocket(MainFrm.UserSRV,strtoint(cmd),'scr4u',Data);
log('>>>>> ADMIN: '+IntToStr(HND)+':::'+cmd+':::'{+streamtostring(data)});
end else TmpStr1 := '';
Exit;
end;
...
UPDATE
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
I : Integer;
List, Messages : TStringList;
begin
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.Lock;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.Unlock;
end;
if Messages <> nil then
begin
for I := 0 to Messages.Count-1 do
begin
AContext.Connection.IOHandler.WriteLn(Messages.Strings[I]);
end;
end;
finally
Messages.Free;
end;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
Command := AContext.Connection.Socket.ReadLn;
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then
begin
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
Is it possible to run code in already running thread? for example: thread1 is running some code & i want to run code from thread2 in thread1.
No. Thread1 needs to be explicitly coded to stop what it is currently doing, do something else, and then go back to what it was previous doing. All Thread2 can do is signal Thread1 to perform that stop+continue at its earliest convenience.
I want to run code in idTCPServer thread to send some data to client
Your TIdTCPServer.OnExecute event handler needs to check for that data periodically and send it when it is available.
You can use the TIdContext.Data property, or derive a custom class from TIdServerContext and assign it to the TIdTCPServer.ContextClass property, to provide a per-client thread-safe buffer for your outbound data. Your OnExecute handler can then access that buffer when needed.
For example:
type
TMyContext = class(TIdServerContext)
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
OutgoingMessages: TIdThreadSafeStringList;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutgoingMessages := TIdThreadSafeStringList.Create;
end;
destructor TMyContext.Destroy;
begin
OutgoingMessages.Free;
inherited;
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
// this must be set before activating the server...
IdTCPServer1.ContextClass := TMyContext;
end;
procedure TMyForm.IdTCPServer1Execute(AContext: TIdContext);
var
List, Messages: TStringList;
begin
// check for outgoing data...
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.LockList;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.UnlockList;
end;
if Messages <> nil then
begin
// send Messages using AContext.Connection.IOHandler as needed...
end;
finally
Messages.Free;
end;
// check for incoming data...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
// process incoming data as needed...
end;
procedure TForm1.SomeProcedure;
var
List: TIdContextList;
Context: TMyContext;
begin
List := IdTCPServer1.Contexts.LockList;
try
Context := TMyContext(List[SomeIndex]);
Context.OutgoingMessages.Add('something');
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
So, I've always faced MAJOR headaches when threading in delphi xe4-6, whether it be from threads not executing, exception handling causes app crashes, or simply the on terminate method never getting called. All the workarounds I've been instructed to use have become very tedious with issues still haunting me in XE6. My code generally has looked something like this:
procedure TmLoginForm.LoginClick(Sender: TObject);
var
l:TLoginThread;
begin
SyncTimer.Enabled:=true;
l:=TLoginThread.Create(true);
l.username:=UsernameEdit.Text;
l.password:=PasswordEdit.Text;
l.FreeOnTerminate:=true;
l.Start;
end;
procedure TLoginThread.Execute;
var
Success : Boolean;
Error : String;
begin
inherited;
Success := True;
if login(USERNAME,PASSWORD) then
begin
// do another network call maybe to get dif data.
end else
begin
Success := False;
Error := 'Login Failed. Check User/Pass combo.';
end;
Synchronize(
procedure
if success = true then
begin
DifferentForm.Show;
end else
begin
ShowMessage('Error: '+SLineBreak+Error);
end;
SyncTimer.Enabled := False;
end);
end;
And then I came across this unit from the samples in Delphi and from the forums:
unit AnonThread;
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections;
type
EAnonymousThreadException = class(Exception);
TAnonymousThread<T> = class(TThread)
private
class var
CRunningThreads:TList<TThread>;
private
FThreadFunc: TFunc<T>;
FOnErrorProc: TProc<Exception>;
FOnFinishedProc: TProc<T>;
FResult: T;
FStartSuspended: Boolean;
private
procedure ThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False;
AFreeOnTerminate: Boolean = True);
class constructor Create;
class destructor Destroy;
end;
implementation
{$IFDEF MACOS}
uses
{$IFDEF IOS}
iOSapi.Foundation
{$ELSE}
MacApi.Foundation
{$ENDIF IOS}
;
{$ENDIF MACOS}
{ TAnonymousThread }
class constructor TAnonymousThread<T>.Create;
begin
inherited;
CRunningThreads := TList<TThread>.Create;
end;
class destructor TAnonymousThread<T>.Destroy;
begin
CRunningThreads.Free;
inherited;
end;
constructor TAnonymousThread<T>.Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False; AFreeOnTerminate: Boolean = True);
begin
FOnFinishedProc := AOnFinishedProc;
FOnErrorProc := AOnErrorProc;
FThreadFunc := AThreadFunc;
OnTerminate := ThreadTerminate;
FreeOnTerminate := AFreeOnTerminate;
FStartSuspended := ACreateSuspended;
//Store a reference to this thread instance so it will play nicely in an ARC
//environment. Failure to do so can result in the TThread.Execute method
//not executing. See http://qc.embarcadero.com/wc/qcmain.aspx?d=113580
CRunningThreads.Add(Self);
inherited Create(ACreateSuspended);
end;
procedure TAnonymousThread<T>.Execute;
{$IFDEF MACOS}
var
lPool: NSAutoreleasePool;
{$ENDIF}
begin
{$IFDEF MACOS}
//Need to create an autorelease pool, otherwise any autorelease objects
//may leak.
//See https://developer.apple.com/library/ios/#documentation/Cocoa/Conceptual/MemoryMgmt/Articles/mmAutoreleasePools.html#//apple_ref/doc/uid/20000047-CJBFBEDI
lPool := TNSAutoreleasePool.Create;
try
{$ENDIF}
FResult := FThreadFunc;
{$IFDEF MACOS}
finally
lPool.drain;
end;
{$ENDIF}
end;
procedure TAnonymousThread<T>.ThreadTerminate(Sender: TObject);
var
lException: Exception;
begin
try
if Assigned(FatalException) and Assigned(FOnErrorProc) then
begin
if FatalException is Exception then
lException := Exception(FatalException)
else
lException := EAnonymousThreadException.Create(FatalException.ClassName);
FOnErrorProc(lException)
end
else if Assigned(FOnFinishedProc) then
FOnFinishedProc(FResult);
finally
CRunningThreads.Remove(Self);
end;
end;
end.
Why is that this anon thread unit above works flawlessly 100% of the time and my code crashes sometimes? For example, I can exec the same thread 6 times in a row, but then maybe on the 7th (or the first for that matter) time it causes the app to crash. No exceptions ever come up when debugging so I dont have a clue where to start fixing the issue. Also, why is it that I need a separate timer that calls "CheckSynchronize" for my code in order to GUI updates to happen but it is not needed when I use the anon thread unit?
Maybe someone can point me in the right direction to ask this question elsewhere if here is not the place. Sorry, I'm diving into documentation already, trying my best to understand.
Here is an example of a thread that may work 20 times in a row, but then randomly cause app to crash
inherited;
try
SQL:= 'Some SQL string';
if GetSQL(SQL,XMLData) then
synchronize(
procedure
var
i:Integer;
begin
try
mTasksForm.TasksListView.BeginUpdate;
if mTasksForm.TasksListView.Items.Count>0 then
mTasksForm.TasksListView.Items.Clear;
XMLDocument := TXMLDocument.Create(nil);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
XMLDocument.LoadFromXML(XMLData);
XMLNode:=XMLDocument.DocumentElement.ChildNodes['Record'];
i:=0;
if XMLNode.ChildNodes['ID'].Text <>'' then
while XMLNode <> nil do
begin
LItem := mTasksForm.TasksListView.Items.AddItem;
with LItem do
begin
Text := XMLNode.ChildNodes['LOCATION'].Text;
Detail := XMLNode.ChildNodes['DESC'].Text +
SLineBreak+
'Assigned To: '+XMLNode.ChildNodes['NAME'].Text
tag := StrToInt(XMLNode.ChildNodes['ID'].Text);
color := TRectangle.Create(nil);
with color do
begin
if XMLNode.ChildNodes['STATUS'].Text = STATUS_DONE then
fill.Color := TAlphaColors.Lime
else if XMLNode.ChildNodes['STATUS'].Text = STATUS_OK then
fill.Color := TAlphaColors.Yellow
else
fill.Color := TAlphaColors.Crimson;
stroke.Color := fill.Color;
ButtonText := XMLNode.ChildNodes['STATUS'].Text;
end;
Bitmap := Color.MakeScreenshot;
end;
XMLNode:=XMLNode.NextSibling;
end;
finally
mTasksForm.TasksListView.EndUpdate;
for i := 0 to mTasksForm.TasksListView.Controls.Count-1 do
begin
if mTasksForm.TasksListView.Controls[I].ClassType = TSearchBox then
begin
SearchBox := TSearchBox(mTasksForm.TasksListView.Controls[I]);
Break;
end;
end;
SearchBox.Text:=' ';
SearchBox.text := ''; //have in here because if the searchbox has text, when attempting to add items then app crashes
end;
end)
else
error := 'Please check internet connection.';
finally
synchronize(
procedure
begin
if error <> '' then
ShowMessage('Erorr: '+error);
mTasksForm.Spinner.Visible:=false;
mTasksForm.SyncTimer.Enabled:=false;
end);
end;
end;
here is the GETSQL method
function GetSQL(SQL:String;var XMLData:String):Boolean;
var
PostResult,
ReturnCode : String;
PostData : TStringList;
IdHTTP : TIdHTTP;
XMLDocument : IXMLDocument;
XMLNode : IXMLNode;
Test : String;
begin
Result:=False;
XMLData:='';
XMLDocument:=TXMLDocument.Create(nil);
IdHTTP:=TIdHTTP.Create(nil);
PostData:=TStringList.Create;
PostData.Add('session='+SessionID);
PostData.Add('database='+Encode(DATABASE,''));
PostData.Add('sql='+Encode(SQL,''));
IdHTTP.Request.ContentEncoding:='UTF-8';
IdHTTP.Request.ContentType:='application/x-www-form-urlencoded';
IdHTTP.ConnectTimeout:=100000;
IdHTTP.ReadTimeout:=1000000;
try
PostResult:=IdHTTP.Post(SERVER_URL+GET_METHOD,PostData);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
test := Decode(PostResult,'');
XMLDocument.LoadFromXML(Decode(PostResult,''));
XMLNode:=XMLDocument.DocumentElement;
try
ReturnCode:=XMLNode.ChildNodes['status'].Text;
except
ReturnCode:='200';
end;
if ReturnCode='' then begin
ReturnCode:='200';
end;
if ReturnCode='200' then begin
Result:=True;
XMLData:=Decode(PostResult,'');
end;
except
on E: Exception do begin
result:=false;
end;
end;
PostData.Free;
IdHTTP.Free;
end;
I have the following problem/question.
I have a unit named "myGlobalFunctions.pas".
Inside this unit I have implemented multiple procedures/functions that are used by several projects.
project 1 use this unit
project 3 use this unit
project 6 use this unit
etc
inside "project 1" there is a thread that use functions inside the "global function" unit.
inside project 3 there is no thread but the functions are used.
so far this thread (project1) provide almost no update of the application interface and the update was made AFTER or BEFORE calling a function from "myGlobalFunctions.pas"
like "before start function1"
... the calling
"after function1".
this way I can know what the program is doing.
However now I want to implement inside the "function1" update of the application interface (with synchronize).
I want to reflect in the application interface "processing step1 ... xx records". (there is a while loop there for a dataset).
using Synchronize for "project1" and with normal label1.caption = 'message'; application.process messages for any other project.
is it possible?
how can I do such a thing.
can be Thread Safe ?
tks a lot
Razvan
here is some code to understand better
THREAD UNIT
procedure TThreadSyncronizeProcess.SignalStart;
begin
frmMain.sbMain.Panels[2].Text := 'Syncronizare in desfasurare...'; -- exist all the time
if Assigned(frmSyncronize) then begin -- check if exist this
frmSyncronize.logMain.WriteFeedBackMessage('Pornire syncronizare...', '', EVENTLOG_INFORMATION_TYPE, True);
end;
end;
procedure TThreadSyncronizeProcess.Execute;
var ..... declarations
begin
Synchronize(SignalStart); -- this is normal call within thread update interface
try
try
workSession := TIB_Session.Create(nil);
workDatabase := TIB_Database.Create(workSession);
... creating more components and setup them ...
uSyncronizareFunctions.SetupDatabase(workDatabase, workSession, transactionWrite, transactionRead);
uSyncronizareFunctions.SetupDataSnapConnection(workConnectionRead, providerRead);
if Assigned(frmSyncronize) then begin
uSyncronizareFunctions.SetupFeedBack(frmSyncronize.logMain);
end;
try
Synchronize(SignalMessage);
// this next function is from the "global unit"
isAllOk := uSyncronizareFunctions.ImportOperatoriAutorizati(workImage, workLabelProgress, True);
isAllOk := isAllOk and uSyncronizareFunctions.ImportJudete;
isAllOk := isAllOk and uSyncronizareFunctions.ImportLocalitati;
isAllOk := isAllOk and uSyncronizareFunctions.ImportUM;
isAllOk := isAllOk and uSyncronizareFunctions.ImportFurnizori;
isAllOk := isAllOk and uSyncronizareFunctions.ImportClasificari;
except
on e : Exception do begin
raise Exception.Create(dmMain.GetDataSnapExceptionMessage(e.Message));
end;
end;
except
on e : Exception do begin
baseMessage := e.Message;
Synchronize(SignalMessage);
end;
end;
finally
workDatabase.ForceDisconnect;
FreeAndNil(transactionRead);
... etc
end;
Synchronize(SignalFinish);
end;
global function unit
unit uSyncronizareFunctions;
function ImportOperatoriAutorizati(imgDone : TImage; labelProgress : TLabel; isThread : Boolean) : Boolean;
var workQuery : TIB_Query;
serverData : TClientDataSet;
begin
Result := True;
try
... create all that we need
serverData.Close;
serverData.CommandText := 'SELECT * FROM OPERATORI_AUTORIZATI WHERE REC_VERSION > :ARECVERSION ORDER BY REC_VERSION, ID';
serverData.Params.Clear;
serverData.Params.CreateParam(ftInteger, 'ARECVERSION', ptInput);
serverData.Params.ParamByName('ARECVERSION').AsInteger := lastVersion;
serverData.Active := True;
...... I want here to signal start
while not serverData.Eof do begin
try
globalInsert_Tran.StartTransaction;
workQuery.Close;
workQuery.ParamByName('AIDGLOBAL').AsString := serverData.FieldByName('IDGLOBAL').AsString;
workQuery.Open;
if workQuery.IsEmpty then begin
workQuery.Insert;
workQuery.FieldByName('IDGLOBAL').AsString := serverData.FieldByName('IDGLOBAL').AsString;
end else begin
workQuery.Edit;
end;
workQuery.FieldByName('NUME').AsString := serverData.FieldByName('NUME').AsString;
workQuery.FieldByName('COD_AUTORIZARE').AsString := serverData.FieldByName('COD_AUTORIZARE').AsString;
workQuery.FieldByName('OTHER_INFO').AsString := serverData.FieldByName('OTHER_INFO').AsString;
workQuery.FieldByName('DATASTERGERE').AsVariant := GetValueDate(serverData.FieldByName('DATASTERGERE').AsDateTime);
workQuery.FieldByName('REC_VERSION').AsInteger := serverData.FieldByName('REC_VERSION').AsInteger;
workQuery.Post;
MarkRecordAsDirtyFalse(workQuery);
globalInsert_Tran.Commit;
...... I want here to signal progress and to see in the application interface "processing record xx/100" or any other message
except
on e : Exception do begin
Result := False;
globalInsert_Tran.Rollback;
end;
end;
serverData.Next;
end;
finally
FreeAndNil(serverData);
FreeAndNil(workQuery);
end;
end;
It looks like you would like your global function to execute a callback. You might try an approach like this:
unit MyGlobalMethods;
interface
uses
System.SysUtils;
type
// define a method signature for your callback
TSomeCallback = procedure(progress : integer) of object;
// add a callback argument to your function (initializing to nil will make
// the parameter optional and will not break your previous implementations)
function GlobalFunction(arg1 : integer;
AMethodCallback : TSomeCallback = nil) : boolean;
implementation
function GlobalFunction(arg1 : integer;
AMethodCallback : TSomeCallback) : boolean;
var i : integer;
begin
for i := 0 to arg1 do begin
sleep(10); // Do some work
// report progress by executing the callback method
// only do this if a method has been passed as argument
if (i mod 100 = 0) and (Assigned(AMethodCallback)) then AMethodCallback(i);
end;
result := true;
end;
end.
Adding a method callback as an argument allows you to pass in any function you like to have the method execute. For example :
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
procedure UpdateProgress(progress : integer);
end;
TSomeThread = class(TThread)
private
FProgressCallback : TSomeCallback;
FProgress : integer;
procedure SynchronizeCallback(progress : integer);
procedure DoCallback;
public
procedure Execute; override;
property OnFunctionProgress : TSomeCallback
read FProgressCallback write FProgressCallback;
end;
implement as :
procedure TSomeThread.Execute;
begin
GlobalFunction(1000, SynchronizeCallback);
end;
procedure TSomeThread.SynchronizeCallback(progress: Integer);
begin
FProgress := progress;
Synchronize(DoCallback);
end;
procedure TSomeThread.DoCallback;
begin
if Assigned(FProgressCallback) then FProgressCallback(FProgress);
end;
You haven't told us what version of Delphi you are using. If you are using D2009 or newer you can bundle the above two calls into one using anonymous methods (and get rid of FProgress) :
procedure TSomeThread.SynchronizeCallback(progress: Integer);
begin
Synchronize(procedure
begin
if Assigned(FProgressCallback) then FProgressCallback(progress);
end;);
end;
Where in your form you would do :
procedure TForm1.UpdateProgress(progress: Integer);
begin
label1.Caption := IntToStr(progress);
end;
procedure TForm1.Button1Click(Sender: TObject);
var someThread : TSomeThread;
begin
someThread := TSomeThread.Create(true);
someThread.FreeOnTerminate := true;
someThread.OnFunctionProgress := UpdateProgress;
someThread.Start;
end;
This nicely separates the responsibilities. The main form passes an update method to the thread (a method, in this case, to update a label). The thread is responsible for synchronizing the call and the global function, therefore, does not need to care whether or not the callback it is executing originates from the main thread or from any other thread. The thread knows it needs to synchronize the method so it should take that responsibility.