Related
I run a simple service.
I can start it and stop it using SCM. I also need the service to stop itself when a condition becomes true.
Question 1 : The service stops when I use the SCM. I click "Stop service", and the service to stop almost instantaneously. However I noticed that the exe stays in the windows task list for about 10 second before stopping. Is that a normal behavior ?
Question 2 : I simulated a condition where I need the service to stop itself by incrementing a variable in the code example below. In this case, the service never stops. I have to kill the task in windows task manager to stop it.
I tried several things without success.
When I stop the service using SCM, the ServiceStop calls the thread Kill method, so thread stops and the service can stop gently.
When the service want to stop itself, the condition is tested from within the thread itself. The thread stops itself, but not the service. So I guess I have to call DoShutDown to tell the service it has to stop. But it does not stop. With or without the DoShutDown call, the service keeps going on.
What am I doing wrong ?
unit TestSvc;
interface
uses
System.SyncObjs
,SysUtils
,Windows
,SvcMgr
,Classes
;
Type
TSvcTh = class(TThread)
private
FEvent : TEvent;
FInterval : Cardinal;
vi_dbg : byte;
protected
procedure Execute; override;
procedure DoTimer;
public
procedure Kill;
Constructor Create();
Destructor Destroy; override;
end;
type
TMyService = class(TService)
procedure ServiceCreate(Sender: TObject);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceShutdown(Sender: TService);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
SelfStop : Boolean;
Svc : TSvcTh;
public
function GetServiceController: TServiceController; override;
end;
var MyService: TMyService;
implementation
procedure ServiceController(CtrlCode: DWord); stdcall;
const sname='ServiceController';
begin
MyService.Controller(CtrlCode);
end;
function TMyService.GetServiceController: TServiceController;
const sname='TMyService.GetServiceController';
begin
Result := ServiceController;
end;
procedure TMyService.ServiceCreate(Sender: TObject);
const sname='TMyService.ServiceCreate';
begin
try
Name := SvcName;
except
on e: exception do begin
end;
end;
end;
procedure TMyService.ServiceShutdown(Sender: TService);
const sname='TMyService.ServiceShutdown';
var Stopped : boolean;
begin
ServiceStop(Self, Stopped);
end;
procedure TMyService.ServiceStart(Sender: TService; var Started: Boolean);
const sname='TMyService.ServiceStart';
begin
SelfStop := false;
Started := false;
try
Dbg(sname + ' ******* STARTING THREAD');
Svc := TSvcTh.Create;
Dbg(sname + '******* THREAD STARTED');
Started := true;
except
on e : exception do begin
Dbg(sname + '============== EXCEPTION =============>' + e.Message);
end;
end;
end;
procedure TMyService.ServiceStop(Sender: TService; var Stopped: Boolean);
const sname='TMyService.ServiceStop';
begin
try
Stopped := True;
if not SelfStop then begin
Dbg(sname + '*** Stop using service controller');
Svc.Kill;
Svc.WaitFor;
Svc.Free;
Svc := nil;
end
else begin
dbg(sname + ' *** Stop by the service itself ') ;
end;
except
on E : Exception do
begin
dbg(sname + ' Exception ! ' + e.Message);
end;
end;
Dbg(sname + '*** END');
end;
procedure TSvcTh.DoTimer;
const sname = 'TSvcTh.DoTimer';
begin
try
inc(vi_dbg);
Dbg(sname + '******* DoTimer');
except
on e : exception do begin
Dbg(sname +' ============== EXCEPTION =============>' + e.Message);
end;
end;
end;
procedure TSvcTh.Execute;
const sname = 'TSvcTh.Execute';
begin
while not Terminated do begin
try
case FEvent.WaitFor(FInterval) of
wrSignaled : begin // Triggered when we stop the service using service controller
Terminate;
end;
wrTimeout : begin
if not Servicemni.SelfStop then begin
DoTimer;
if vi_dbg > 5 then begin
MyService.SelfStop := true; // Testing auto stop
terminate;
end;
end;
end;
end;
except
on e : exception do begin
Dbg(sname + ' ============== EXCEPTION =============>' + e.Message);
end;
end;
end;
if MyService.SelfStop then begin
MyService.DoShutdown;
end;
Dbg(sname + ' ARRET ... ' + StrLog(MyService.Terminated));
if MyService.SelfStop then begin
MyService.ReportStatus;
end;
end;
Constructor TSvcTh.Create();
const sname = 'TSvcTh.Create';
begin
FEvent := TEvent.Create(nil, False, False, '');
FInterval := heartbeat;
vi_dbg := 0;
inherited Create(False);
end;
destructor TSvcTh.Destroy;
const sname = 'TSvcTh.Destroy';
begin
try
if assigned(FEvent) then begin
FreeAndNil(FEvent);
end;
except
on e:exception do begin
Dbg(sname + '==========================> EXCEPTION : '+ e.Message);
end;
end;
inherited;
end;
procedure TSvcTh.Kill;
const sname = 'TSvcTh.Kill';
begin
try
FEvent.SetEvent;
except
on e:exception do begin
dbg(sname + ' ==========================> EXCEPTION : '+ e.Message);
end;
end;
end;
end.
UPDATE :
If I add a ServiceExecute method and modify the Svc thread to just set SelfStop to true (without terminate it), the service ends. But it does not seem very elegant. And I can't figure out why it is needed. In fact, the service seems to create a thread "ServiceExecute" anyway. But if I don't write this method, ProcessRequest is never called and the "ServiceExecute" never ends when the Svc thread ends. Furthermore, the process still stays about 30 seconds in windows task manager (Process Explorer from sysinternals) after the service end.
procedure TSvcTh.Execute;
const sname = 'TSvcTh.Execute';
begin
while not Terminated do begin
try
case FEvent.WaitFor(FInterval) of
wrSignaled : begin // Triggered when we stop the service using service controller
Terminate;
end;
wrTimeout : begin
DoTimer;
if vi_dbg > 5 then begin
MyService.SelfStop := true; // Testing auto stop
end;
end;
end;
except
on e : exception do begin
Dbg(sname + ' ============== EXCEPTION =============>' + e.Message);
end;
end;
end;
end;
procedure TMyService.ServiceExecute(Sender: TService);
begin
while not terminated do begin
ServiceThread.ProcessRequests(false);
if SelfStop then begin
ServiceThread.terminate;
Svc.Terminate;
Svc.WaitFor;
Svc.Free;
Svc := nil;
end;
sleep(1000);
end;
UPDATE 2: The explication for the delay of 30 seconds for the service to terminate seems to be here
If the thread wants to terminate itself, it can invoke the SCM informing that the service needs to stop which in turn will terminate the thread as shown in the proof of concept code below. To make this work, I pass an anonymous method to the Thread constructor to avoid to have a dependency on the Service itself (and the thread code can be tested outside a service).
If you start the service and do nothing, it will shutdown itself after 10 seconds.
Service code:
unit Unit1;
interface
uses
Unit2,
WinApi.WinSvc,
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs;
type
TService1 = class(TService)
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
{ Private declarations }
MyThread : TMyThread;
Eventlog : TEventLogger;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
Service1: TService1;
implementation
{$R *.dfm}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
Service1.Controller(CtrlCode);
end;
function TService1.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TService1.ServiceStart(Sender: TService; var Started: Boolean);
begin
EventLog := TEventLogger.Create('Service1');
// call our thread and inject code for premature service shutdown
MyThread := TMyThread.Create(procedure begin Service1.Controller(SERVICE_CONTROL_STOP) end);
MyThread.Start;
EventLog.LogMessage('Started');
end;
procedure TService1.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
EventLog.LogMessage('Stop');
MyThread.Terminate;
// Give some time to the thread to cleanup, then bailout
WaitForSingleObject(MyThread.Handle, 5000);
EventLog.LogMessage('Stopped');
EventLog.Free;
Stopped := True;
end;
end.
Worker thread:
unit Unit2;
interface
uses
SysUtils,
Vcl.SvcMgr,
Windows,
System.Classes;
type
TSimpleProcedure = reference to procedure;
TMyThread = class(TThread)
private
{ Private declarations }
ShutDownProc : TSimpleProcedure;
EventLog : TEventLogger;
protected
procedure Execute; override;
public
constructor Create(AShutDownProc: TSimpleProcedure);
destructor Destroy; override;
end;
implementation
{ MyThread }
constructor TMyThread.Create(AShutDownProc: TSimpleProcedure);
begin
inherited Create(True);
ShutDownProc := AShutDownProc;
end;
procedure TMyThread.Execute;
var
Count : Integer;
Running : Boolean;
begin
EventLog := TEventLogger.Create('MyThread');
EventLog.LogMessage('Thread Started');
Count := 0;
Running := True;
while not Terminated and Running do
begin
EventLog.LogMessage(Format('Count: %d', [Count]));
Running := Count <> 10;
Inc(Count);
if Running then
Sleep(1000); // do some work
end;
// if thread wants to stop itself, call service thread shutdown and wait for termination
if not Running and not Terminated then
begin
EventLog.LogMessage(Format('Thread Wants to Stop', [Count]));
ShutDownProc();
end;
EventLog.LogMessage(Format('Thread Await terminate', [Count]));
// await termination
while not Terminated do Sleep(10);
EventLog.LogMessage(Format('Thread Terminated', [Count]));
EventLog.Free;
end;
end.
I have a really slow query that always make windows mark my program as Not responding. I decided to create a background worker to perform this query while the main thread show a GIF. I did everything and it works! =D
But... When I close my Form I got a EInvalidPointer Exception, ONLY when I use the worker thread.
Here is my code:
Main thread Call to worker thread
if not TThreadDB.ExecutarThreadDB(cdsSolicitacao,
FConsultaSql,
nil,
tpHigher) then
begin
Exit;
end;
Where:
cdsSolicitacao is a clientDataSet I want to share between the threads,
FConsultaSql string (my query)
My thread Unit
unit UThreadDB;
interface
uses Classes, DBClient, DB, SysUtils, Variants, JvJCLUtils;
type
TParametros = class
private
FTotal: Integer;
FCampo: array of string;
FTipo: array of TFieldType;
FValor: array of Variant;
public
constructor Create(ACampos: string; ATipos: array of TFieldType; AValores: array of Variant); reintroduce;
end;
TThreadDB = class(TThread)
private
FExecutou: Boolean;
FClientDataSet: TClientDataSet;
FConsultaSQL: string;
FParametros: TParametros;
procedure CarregarDados;
protected
procedure Execute; override;
public
constructor Create(ACreateSuspended: Boolean; AClientDataSet: TClientDataSet; AConsultaSQL: string = '';
AParametros: TParametros = nil); reintroduce;
class function ExecutarThreadDB(AClientDataSet: TClientDataSet; AConsultaSQL: string = '';
AParametros: TParametros = nil; APriority: TThreadPriority = tpNormal): Boolean;
class procedure ExecutarThreadDBParalela(AThreadDB: TThreadDB; AClientDataSet: TClientDataSet;
AConsultaSQL: string = ''; AParametros: TParametros = nil; APriority: TThreadPriority = tpNormal);
end;
implementation
uses
BIBLIO;
{ TThreadDB }
class function TThreadDB.ExecutarThreadDB(AClientDataSet: TClientDataSet; AConsultaSQL: string = '';
AParametros: TParametros = nil; APriority: TThreadPriority = tpNormal): Boolean;
var
lThreadDB: TThreadDB;
begin
lThreadDB := TThreadDB.Create(True, AClientDataSet, AConsultaSQL, AParametros);
try
//lThreadDB.FreeOnTerminate := True;
lThreadDB.Priority := APriority;
lThreadDB.Resume;
lThreadDB.WaitFor;
Result := lThreadDB.FExecutou;
finally
lThreadDB.Terminate;
//lThreadDB := nil;
FreeAndNil(lThreadDB);
end;
end;
class procedure TThreadDB.ExecutarThreadDBParalela(AThreadDB: TThreadDB; AClientDataSet: TClientDataSet;
AConsultaSQL: string = ''; AParametros: TParametros = nil; APriority: TThreadPriority = tpNormal);
begin
AThreadDB := TThreadDB.Create(True, AClientDataSet, AConsultaSQL, AParametros);
AThreadDB.FreeOnTerminate := True;
AThreadDB.Priority := APriority;
AThreadDB.Resume;
end;
procedure TThreadDB.CarregarDados;
var
lIndex: Integer;
begin
FClientDataSet.Close;
try
if (FConsultaSQL <> '') then
begin
FClientDataSet.CommandText := FConsultaSQL;
end;
if (FParametros <> nil) then
begin
for lIndex := 0 to (FParametros.FTotal - 1) do
begin
case FParametros.FTipo[lIndex] of
ftInteger : FClientDataSet.Params.ParamByName(FParametros.FCampo[lindex]).AsInteger := FParametros.FValor[lIndex];
ftString : FClientDataSet.Params.ParamByName(FParametros.FCampo[lindex]).AsString := FParametros.FValor[lIndex];
ftDate : FClientDataSet.Params.ParamByName(FParametros.FCampo[lindex]).AsDate := FParametros.FValor[lIndex];
end;
end;
end;
FClientDataSet.Open;
FExecutou := True;
except
on E: Exception do
begin
Erro('Não foi possível carregar os dados solicitados!' + #13 +
'Classe do erro: ' + E.ClassName + #13 +
'Mensagem: ' + E.Message);
end;
end;
if (FParametros <> nil) then
begin
FreeAndNil(FParametros);
end;
end;
constructor TThreadDB.Create(ACreateSuspended: Boolean; AClientDataSet: TClientDataSet; AConsultaSQL: string = '';
AParametros: TParametros = nil);
begin
inherited Create(ACreateSuspended);
FClientDataSet := AClientDataSet;
FConsultaSQL := AConsultaSQL;
FParametros := AParametros;
FExecutou := False;
end;
procedure TThreadDB.Execute;
begin
CarregarDados;
end;
{ TParametros }
constructor TParametros.Create(ACampos: string; ATipos: array of TFieldType; AValores: array of Variant);
var
lIndex: Integer;
begin
inherited Create;
FTotal := ContaCaracteres(ACampos, ';') + 1;
SetLength(FCampo, FTotal);
SetLength(FTipo, FTotal);
SetLength(FValor, FTotal);
for lIndex := 0 to FTotal - 1 do
begin
FCampo[lIndex] := ExtractDelimited(lIndex + 1, ACampos , [';']);
end;
for lIndex := 0 to FTotal - 1 do
begin
FTipo[lIndex] := ATipos[lIndex];
end;
for lIndex := 0 to FTotal - 1 do
begin
FValor[lIndex] := AValores[lIndex];
end;
end;
end.
Any ideas of what I'm missing?
You haven't mentioned that in your question, but I guess the problem you describe may be caused by modifying dataset object, which is at the same time consumed by the main thread (displayed in a grid, for example). In other words, that you're passing to a worker thread dataset, which is linked to some controls in your main thread. Or, yet another way described, your cdsSolicitacao dataset object is linked through data source object to some control(s) on your main form.
Do note that main thread cannot ever work with an object that is being modified by a worker thread.
And even modal animation won't stop main thread from consuming that just modified dataset. For example DB grid can be requested for repaint which needs access to its underlying dataset which is at the same time being modified by a worker thread.
If that is your case, and you don't want to create a new dataset instance that you then replace with the consumed one when the worker thread finishes,
you'll need to (ideally) disconnect that dataset object from every linked control before passing to the worker thread and reconnect when finishes.
I have several threads (Providers), that are used by other threads (Workers) on concurrent basis.
Several threads means severan critical sections according to threads.
Is it impossble to place a critical section variable inside a thread class, or its better to hold separate array for critical section of each thread that needs to be concurrently accessed?
Or there is a better practice?
UPD: a bit explanation.
Process flow is:
Worker loads a pool of data to its self
In cycle of own pool of data a Worker try to gain access to a Provider
Worker gains access to Provider ->
Worker locks it ->
Worker posts data to Provider from own pool ->
Provider start doing a job ->
When job is done Provider sends event to Worker ->
Worker gets a result ->
Worker release lock ->
Goto 2 or exit if last data from pool was processed
This actually works fine in a real situation with a very good outcome.
But the problem is when I need to kill one of the Providers.
If a critical section inside a Provider class, then its possible to get access violation once a Worker already entered CS and waiting for unlock and a provider is not really terminated yet, but terminated next step.
if not Provider.Terminated then
Provider.CS.Enter; //This is a place where AV occurs.
Provider.PostData(Worker.Data);
Provider.StartJob;
WaitForSingleObject(Provider.EventJobIsDone, 30000);
Provider.CS.Leave; //or here
If I have to place CS outside - how it is better to do this and to test that a provider is terminated?
Several Providers and many Workers, that are created / terminated at any time and should work together. There is no option, that one Worker process all its pool of data while others are waiting. Each Worker do one iteration and then waits while other Workers do the same, then again it do next iteration then again waits while others do the same and so on until all pools are proccessed and Workers are terminated (each on its own time, when pool is finished).
Each iteration of Worker and result it gets influence what Provider would be chosen for that Worker next time.
And again - this works fine in real conditions and no stucks happen. Very fast and quite as it is expected to work.
Example
A rough example.
You have Worker threads, that load a pool of data from DB. There are different DBs, not only one. Each item - is a heavy picture 0.1Mb-10Mb - you never know before. Imagine each Worker has 100-5000 items to be processed - you need to convert it to a lesser picture or do some other process. You never know how many items there would be in any next Worker thread. It could be 10, 1000, 5000, more or less. Whenever a Worker thread is started - there should be no timeout for a new Worker thread to start processing its first item from data pool, because it's a waste of time that costs.
You have 10 Providers, that are connected to 10 machines on the local network. Those machines do all the work you need remotely. (a rough example, please)
You should balance (the real strategy is more complex and depends on the actual data - it's similar to: is it a JPG, TIFF, PNG, BMP or whatever format, but simply please think of balance) traffic among all the Providers correctly. To do this you should count the quantity of processed data and decide each iteration where to put next Worker call - to Provider1,2,3...or 10. Besides you need to return a result immediately to the calling Worker, because a Worker should give an immediate report, write a flag to DB (only Worker knows which DB) that data is processed (!important) and so on.
That's are the conditions.
In brief:
10-50 Workers at a time with 100-5000 items
Workers are started and finished on their own
You can't do a prognosis how many Workers there would be at any time
Service is working 24/7 and ready to process data
10 Providers, each is a connection to a machine on the network
A new Worker should as soon as possible start processing its data
A need to balance traffic among Providers on-the-fly
Amount of processed data thru each Provider affects the decision to choose next Provider for a next data process.
Worker should always get a result and update data to DB
Suddenly you are about to terminate a Provider
Some Workers already waiting to process data with this one Provider
How to tell the Workers to stop waiting and when they are unfreezed - how to avoid Access violation that is pretty sure may occur on the next step in Worker flow (which is presented in the code in above).
Your problem boils down to following scenario:
A provider thread with a CS inside has to terminate.
Multiple worker threads could be blocked, waiting for the CS to be released.
Provider thread is terminated just after the CS is released, causing all pending threads to access a non-existing thread.
This is a design problem, never access a thread that could be terminated without notice. You could solve it by some communication.
Perhaps let the provider live long enough to tell all other worker threads that it is time to say goodbye. Set a semaphore, answer all pending requests with an end of life message. Make sure the worker threads looks at the semaphore before sending a request.
I have the impression from what you write, that a lot of the system is not under your control. Im still a bit uncertain how much you are allowed to change.
I have implemented a global Controller : TSystemController class which is used to control all the parts.
I understand it is not up to you when a Provider is terminated.
Therefore I believe it is only possible to avoid AV by adding a global ProviderJob List/Queue.
The worker will Push jobs and the provider will Pop jobs.
A Critical Section is used for consistency during Push / Pop by the many involved threads.
I have only used one critical section, since this Queue is responsible for holding all Jobs for the entire system.
A ProviderJob : TProviderJob, holds a ThreadID to the provider thread to avoid reference to a killed/freed provider. Besides the WorkItem a DoneEvent given by the worker is needed, so the Provider can signal when its done to the waiting worker.
If the Provider is suddenly is killed, the worker will just wait for 30 seconds and time out.
TProviderJob = class
FProviderThreadID : Cardinal;
FWorkItem : TWorkItem;
FWorkDoneEvent : TEvent;
public
property ProviderThreadID : Cardinal read FProviderThreadID;
property WorkItem : TWorkItem read FWorkItem;
property WorkDoneEvent : TEvent read FWorkDoneEvent;
end;
The ProviderJob gets pushed by a Worker thread as follows (no direct reference to the Provider object):
ProviderID := Controller.GetProviderThreadID;
Controller.PushWorkItemToProviderJobList( ProviderID, CurrentWorkItem, WorkDoneEvent );
The worker will wait until the Provider is done with the job:
if WaitForSingleObjehect( WorkDoneEvent.Handle, 30000 ) = WAIT_OBJECT_0 then
begin
if CurrentWorkItem.State = wisProcessedOK then
begin
Inc(Controller.FWorkItemsDone);
Inc(NextWorkItemIdx);
if NextWorkItemIdx >= WorkItems.Count then
Terminate;
end;
end;
The individual Provider is processing jobs as follows:
procedure TProviderThread.Execute;
var
WorkItem: TWorkItem;
WorkDoneEvent: TEvent;
begin
while not Terminated do
begin
Controller.PopNextWorkItemFromProviderJobList( self.ThreadID, WorkItem, WorkDoneEvent );
if (WorkItem<>nil) and (WorkDoneEvent<>nil) then
begin
WorkItem.FState := wisStarted;
Sleep( Round( Random( 5000 )));
WorkItem.FState := wisProcessedOK;
WorkDoneEvent.SetEvent;
end
else
Sleep(500);
end;
end;
Here is an example:
Screenshot of the test app
Here is the full solution:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 248
ClientWidth = 477
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo1: TMemo
Left = 8
Top = 8
Width = 369
Height = 209
Lines.Strings = (
'Memo1')
TabOrder = 0
end
object bStart: TButton
Left = 383
Top = 72
Width = 75
Height = 25
Caption = 'Start'
TabOrder = 1
OnClick = bStartClick
end
object bStop: TButton
Left = 383
Top = 103
Width = 75
Height = 25
Caption = 'Stop'
TabOrder = 2
OnClick = bStopClick
end
object bKillProvider: TButton
Left = 383
Top = 134
Width = 75
Height = 25
Caption = 'Kill Provider'
TabOrder = 3
OnClick = bKillProviderClick
end
object Timer1: TTimer
OnTimer = Timer1Timer
Left = 400
Top = 8
end
end
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, Math;
type
TForm1 = class(TForm)
Timer1: TTimer;
Memo1: TMemo;
bStart: TButton;
bStop: TButton;
bKillProvider: TButton;
procedure Timer1Timer(Sender: TObject);
procedure bKillProviderClick(Sender: TObject);
procedure bStopClick(Sender: TObject);
procedure bStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
System.SyncObjs,
Generics.Collections;
type
TWorkItemStateE = ( wisNotStarted, wisStarted, wisProcessedOK );
TWorkItem = class
private
FState : TWorkItemStateE;
FID : Integer;
public
property ID : Integer read FID;
property State: TWorkItemStateE read FState;
end;
TWorkItemList = class(TObjectList<TWorkItem>);
TWorkerThread = class(TThread)
protected
procedure Execute; override;
end;
TWorkerThreadList = class(TObjectList<TWorkerThread>);
TProviderThread = class(TThread)
protected
procedure Execute; override;
end;
TProviderThreadList = TObjectList<TProviderThread>;
TProviderJob = class
FProviderThreadID : Cardinal;
FWorkItem : TWorkItem;
FWorkDoneEvent : TEvent;
public
property ProviderThreadID : Cardinal read FProviderThreadID;
property WorkItem : TWorkItem read FWorkItem;
property WorkDoneEvent : TEvent read FWorkDoneEvent;
end;
TProviderJobList = TObjectList<TProviderJob>;
TSystemContoller = class
private
FProviders: TProviderThreadList;
FWorkers : TWorkerThreadList;
FGlobalProviderJobList : TProviderJobList;
FCS_GlobalProviderJobList: TCriticalSection;
FStarted : Boolean;
FRemovedProviders: Integer;
FKilledProviders: Integer;
FRemovedWorkers: Integer;
FWorkItemsDone: Integer;
FStartedDateTime: TDateTime;
procedure ThreadTerminated(Sender: TObject);
procedure AddProvider;
procedure AddWorker;
public
constructor Create;
destructor Destroy; override;
function GetProvider : TProviderThread;
function GetProviderThreadID: Cardinal;
procedure PopNextWorkItemFromProviderJobList(
const AProviderThreadID: Cardinal;
out NextWorkItem: TWorkItem;
out NextWorkDoneEvent: TEvent);
procedure PushWorkItemToProviderJobList(
AProviderThreadID: Cardinal;
AWorkItem: TWorkItem;
AWorkDoneEvent: TEvent);
procedure Start;
procedure Stop;
procedure KillProvider;
function GetStatusReport : String;
end;
var
Controller : TSystemContoller;
{ TWorkThread }
procedure TWorkerThread.Execute;
procedure LoadWorkItems( AWorkItems : TWorkItemList );
var
WorkItemCount: Integer;
n : Integer;
WorkItem: TWorkItem;
begin
// Load work items:
WorkItemCount := 1+Round(Random(10));
for n := 1 to WorkItemCount do
begin
WorkItem := TWorkItem.Create;
WorkItem.FID := n;
AWorkItems.Add(WorkItem);
end;
end;
var
WorkItems : TWorkItemList;
ProviderID: Cardinal;
NextWorkItemIdx: Integer;
CurrentWorkItem: TWorkItem;
WorkDoneEvent : TEvent;
begin
WorkItems := TWorkItemList.Create;
WorkDoneEvent := TEvent.Create(nil, False, False, '' );
try
// load:
LoadWorkItems( WorkItems );
// process work items:
NextWorkItemIdx := 0;
while not Terminated do
begin
CurrentWorkItem := WorkItems[ NextWorkItemIdx ];
ProviderID := Controller.GetProviderThreadID;
Controller.PushWorkItemToProviderJobList( ProviderID, CurrentWorkItem, WorkDoneEvent );
if WaitForSingleObject( WorkDoneEvent.Handle, 30000 ) = WAIT_OBJECT_0 then
begin
if CurrentWorkItem.State = wisProcessedOK then
begin
Inc(Controller.FWorkItemsDone);
Inc(NextWorkItemIdx);
if NextWorkItemIdx >= WorkItems.Count then
Terminate;
end;
end;
Sleep(1000);
end;
finally
WorkDoneEvent.Free;
WorkItems.Free;
end;
end;
{ TProviderThread }
procedure TProviderThread.Execute;
var
WorkItem: TWorkItem;
WorkDoneEvent: TEvent;
begin
while not Terminated do
begin
Controller.PopNextWorkItemFromProviderJobList( self.ThreadID, WorkItem, WorkDoneEvent );
if (WorkItem<>nil) and (WorkDoneEvent<>nil) then
begin
WorkItem.FState := wisStarted;
Sleep( Round( Random( 5000 )));
WorkItem.FState := wisProcessedOK;
WorkDoneEvent.SetEvent;
end
else
Sleep(500);
end;
end;
{ TSystemContoller }
constructor TSystemContoller.Create;
begin
inherited;
FStartedDateTime:= now;
FCS_GlobalProviderJobList := TCriticalSection.Create;
FGlobalProviderJobList := TProviderJobList.Create;
FProviders:= TProviderThreadList.Create;
FProviders.OwnsObjects := False;
FWorkers := TWorkerThreadList.Create;
FWorkers.OwnsObjects := False;
end;
destructor TSystemContoller.Destroy;
begin
FCS_GlobalProviderJobList.Free;
FGlobalProviderJobList.Free;
FWorkers.Free;
FProviders.Free;
inherited;
end;
procedure TSystemContoller.Start;
var
n: Integer;
begin
if not FStarted then
begin
FStarted := True;
for n := 1 to 5 do
AddProvider;
for n := 1 to 10 do
AddWorker;
end;
end;
procedure TSystemContoller.Stop;
var
n: Integer;
begin
for n := FProviders.Count-1 to 0 do
FProviders[n].Terminate;
for n := FWorkers.Count-1 to 0 do
FWorkers[n].Terminate;
FStarted := False;
end;
procedure TSystemContoller.KillProvider;
var
Provider: TProviderThread;
begin
Provider := GetProvider;
if Provider<>nil then
begin
if not Provider.Terminated then
begin
GetProvider.Terminate;
Inc( FKilledProviders );
end;
end;
end;
procedure TSystemContoller.AddProvider;
var
Provider: TProviderThread;
begin
Provider := TProviderThread.Create(True);
Provider.OnTerminate := ThreadTerminated;
Provider.FreeOnTerminate := True;
FProviders.Add( Provider );
Provider.Start;
end;
procedure TSystemContoller.AddWorker;
var
Worker: TWorkerThread;
begin
Worker := TWorkerThread.Create(True);
Worker.OnTerminate := ThreadTerminated;
Worker.FreeOnTerminate := True;
FWorkers.Add( Worker );
Worker.Start;
end;
procedure TSystemContoller.ThreadTerminated(Sender : TObject );
begin
if Sender is TProviderThread then
begin
FProviders.Remove(TProviderThread(Sender));
Inc(FRemovedProviders);
if FStarted then
AddProvider;
end
else
if Sender is TWorkerThread then
begin
FWorkers.Remove(TWorkerThread(Sender));
Inc(FRemovedWorkers);
if FStarted then
AddWorker;
end;
end;
procedure TSystemContoller.PushWorkItemToProviderJobList(
AProviderThreadID: Cardinal;
AWorkItem: TWorkItem;
AWorkDoneEvent: TEvent);
var
ProviderJob: TProviderJob;
begin
FCS_GlobalProviderJobList.Enter;
try
ProviderJob := TProviderJob.Create;
ProviderJob.FProviderThreadID := AProviderThreadID;
ProviderJob.FWorkItem := AWorkItem;
ProviderJob.FWorkDoneEvent := AWorkDoneEvent;
FGlobalProviderJobList.Add( ProviderJob );
finally
FCS_GlobalProviderJobList.Leave;
end;
end;
procedure TSystemContoller.PopNextWorkItemFromProviderJobList(
const AProviderThreadID: Cardinal;
out NextWorkItem: TWorkItem;
out NextWorkDoneEvent: TEvent);
var
n : Integer;
begin
FCS_GlobalProviderJobList.Enter;
try
NextWorkItem := nil;
NextWorkDoneEvent := nil;
for n := 0 to FGlobalProviderJobList.Count-1 do
begin
if FGlobalProviderJobList[n].ProviderThreadID = AProviderThreadID then
begin
NextWorkItem := FGlobalProviderJobList[n].WorkItem;
NextWorkDoneEvent := FGlobalProviderJobList[n].WorkDoneEvent;
FGlobalProviderJobList.Delete(n);
Exit;
end;
end;
finally
FCS_GlobalProviderJobList.Leave;
end;
end;
function TSystemContoller.GetProvider: TProviderThread;
var
ProviderIdx: Integer;
begin
ProviderIdx := Trunc(Random( FProviders.Count ));
if InRange(ProviderIdx, 0, FProviders.Count-1 ) then
Result := FProviders[ ProviderIdx ]
else
Result := nil;
end;
function TSystemContoller.GetProviderThreadID: Cardinal;
var
Provider: TProviderThread;
begin
Provider := GetProvider;
if Provider<>nil then
Result := Provider.ThreadID;
end;
function TSystemContoller.GetStatusReport: String;
const
cState : array[Boolean] of string = ( 'Stopped', 'Started' );
begin
Result := 'Start Date and Time: ' + DateTimeToStr(FStartedDateTime) + #13#10+
'Date and Time: ' + DateTimeToStr(now) + #13#10+
'System State: ' + cState[FStarted] + #13#10+ #13#10 +
'Queued Work Items: ' + IntToStr( self.FGlobalProviderJobList.Count )+ #13#10 +
'Work Items Done: ' + IntToStr(FWorkItemsDone)+ #13#10 + #13#10 +
'Current Providers: ' + IntToStr( self.FProviders.Count ) + #13#10+
'Removed Providers: ' + IntToStr( FRemovedProviders ) + #13#10 +
'Random Provider Kills: ' + IntToStr(FKilledProviders)+ #13#10 + #13#10 +
'Current Workers: ' + IntToStr( self.FWorkers.Count ) + #13#10 +
'Removed Workers: ' + IntToStr( FRemovedWorkers );
end;
procedure TForm1.bKillProviderClick(Sender: TObject);
begin
Controller.KillProvider;
end;
procedure TForm1.bStartClick(Sender: TObject);
begin
Controller.Start;
end;
procedure TForm1.bStopClick(Sender: TObject);
begin
Controller.Stop;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Memo1.Text := Controller.GetStatusReport;
if Random(100) < 30 then
Controller.KillProvider;
end;
initialization
Controller := TSystemContoller.Create;
Controller.Start;
finalization
Controller.Stop;
Controller.Free;
end.
With this code I call a form
procedure TfrmMain.actDevTest_2Execute(Sender: TObject);
var
SelectedApp: string;
begin
if ApplicationSelect(Self, SelectedApp) then
ShowMessage(SelectedApp);
end;
The form is looking like the following
unit F_JsApplicationSelect;
interface
uses
{$Include UniDACCommon.inc}
Db, MemDS, DbAccess, Uni,
Classes, Controls, Forms,
U_Forms.Move,
Winapi.Messages, U_CustomMessages,
Dialogs, StdCtrls, Buttons, ComCtrls,
cxGroupBox, cxGraphics, cxControls, cxLookAndFeels,
cxLookAndFeelPainters, cxStyles, dxSkinsCore, dxSkinOffice2010Blue,
dxSkinscxPCPainter, cxCustomData, cxFilter, cxData, cxDataStorage, cxEdit,
cxNavigator, cxDBData, cxCheckBox, cxTextEdit, cxContainer, Vcl.Menus,
cxButtons, cxGridLevel, cxGridCustomTableView, cxGridTableView,
cxGridDBTableView, cxClasses, cxGridCustomView, cxGrid,
dxmdaset;
type
TfrmJsApplicationSelect = class(TForm)
grdApplicationsView1: TcxGridDBTableView;
grdApplicationsLevel1: TcxGridLevel;
grdApplications: TcxGrid;
colContact: TcxGridDBColumn;
colSection: TcxGridDBColumn;
colSelected: TcxGridDBColumn;
cxGroupBox1: TcxGroupBox;
btnOK: TcxButton;
srcApplications: TUniDataSource;
mdApplications: TdxMemData;
mdApplicationsfldselected: TBooleanField;
mdApplicationsfldcontact: TStringField;
mdApplicationsfldsection: TStringField;
mdApplicationsfldposition: TStringField;
mdApplicationsflddate: TDateField;
mdApplicationsfldguid: TStringField;
colPosition: TcxGridDBColumn;
colDdate: TcxGridDBColumn;
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
procedure grdApplicationsView1CellDblClick(Sender: TcxCustomGridTableView;
ACellViewInfo: TcxGridTableDataCellViewInfo; AButton: TMouseButton;
AShift: TShiftState; var AHandled: Boolean);
private
procedure SetupApplications;
procedure MessageClose(var aMessage: TMessage); message WM_FORMCLOSE;
public
constructor Create(aOwner: TComponent; var aApplication: string); reintroduce;
end;
function ApplicationSelect(aOwner: TComponent; var aApplication: string): boolean;
implementation
{$R *.dfm}
uses
System.SysUtils, Winapi.Windows,
F_UniConn,
U_Logfile,
U_AppDb, U_User;
var
lApplication : string;
function ApplicationSelect(aOwner: TComponent; var aApplication: string): boolean;
begin
with TfrmJsApplicationSelect.Create(aOwner, aApplication) do
try
Result := ShowModal = mrOK;
finally
Release;
end;
end;
procedure TfrmJsApplicationSelect.MessageClose(var aMessage: TMessage);
begin
Close;
end;
procedure TfrmJsApplicationSelect.SetupApplications;
var
Query: TUniQuery;
begin
Query := frmUniConn.CreateQuery;
try
Query.SQL.Clear;
Query.SQL.Add('SELECT fldapplication_guid');
Query.SQL.Add(' ,fldapplication_date');
Query.SQL.Add(' ,fldcontact_name');
Query.SQL.Add(' ,fldsection_desc');
Query.SQL.Add(' ,fldposition_desc');
Query.SQL.Add(' ,fldcreated_by');
Query.SQL.Add(' FROM ' + QueryJsApplications);
Query.SQL.Add(' WHERE (fldcreated_by = :fldcreated_by)');
Query.SQL.Add(' ORDER BY fldapplication_date DESC');
Query.ParamByName('fldcreated_by').AsString := User.ID;
try
Query.Execute;
if Query.RecordCount > 0 then
begin
while not Query.Eof do
begin
mdApplications.Open;
mdApplications.Append;
mdApplications.FieldByName('fldselected').AsBoolean := False;
mdApplications.FieldByName('fldguid').AsString := Query.FieldByName('fldapplication_guid').AsString;
mdApplications.FieldByName('flddate').AsDateTime := Query.FieldByName('fldapplication_date').AsDateTime;
mdApplications.FieldByName('fldcontact').AsString := Query.FieldByName('fldcontact_name').AsString;
mdApplications.FieldByName('fldsection').AsString := Query.FieldByName('fldsection_desc').AsString;
mdApplications.FieldByName('fldposition').AsString := Query.FieldByName('fldposition_desc').AsString;
mdApplications.FieldByName('fldguid').AsString := Query.FieldByName('fldapplication_guid').AsString;
mdApplications.Post;
Query.Next;
end;
mdApplications.First;
end;
except
on E:exception do
Logfile.Error('F_JsApplicationSelect.SetupApplications: ' + E.Message);
end;
finally
Query.Free;
end;
end;
constructor TfrmJsApplicationSelect.Create(aOwner: TComponent; var aApplication: string);
begin
inherited Create(aOwner);
lApplication := aApplication;
end;
procedure TfrmJsApplicationSelect.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
mdApplications.First;
while not mdApplications.Eof do
begin
if mdApplications.FieldByName('fldselected').AsBoolean = True then
begin
ShowMessage(mdApplications.FieldByName('fldguid').AsString);
lApplication := mdApplications.FieldByName('fldguid').AsString;
ShowMessage(lApplication);
end;
mdApplications.Next;
end;
except
on E: exception do
Logfile.Error('F_JsApplicationSelect.FormClose: ' + E.Message);
end;
end;
procedure TfrmJsApplicationSelect.FormKeyPress(Sender: TObject; var Key: Char);
begin
If Ord(Key) = 27 Then
ModalResult := mrAbort;
end;
procedure TfrmJsApplicationSelect.FormShow(Sender: TObject);
begin
SetupApplications;
ActiveControl := grdApplications;
if grdApplicationsView1.DataController.RecordCount > 0 then
begin
grdApplicationsView1.Controller.GoToFirst(False);
grdApplicationsView1.Controller.FocusedRecord.MakeVisible;
end;
end;
procedure TfrmJsApplicationSelect.grdApplicationsView1CellDblClick(
Sender: TcxCustomGridTableView; ACellViewInfo: TcxGridTableDataCellViewInfo;
AButton: TMouseButton; AShift: TShiftState; var AHandled: Boolean);
begin
try
mdApplications.Edit;
mdApplications.FieldByName('fldselected').AsBoolean := Not mdApplications.FieldByName('fldselected').AsBoolean;
mdApplications.UpdateRecord;
except
on E: exception do
Logfile.Error('F_JsApplicationSelect.grdApplicationsView1CellDblClick: ' + E.Message);
end;
end;
end.
But why don't I get any value in my SelectedApp variable?
I have another form with identical functions only the var I send to it is a TStringList - that works OK. But the string doesn't work at all.
The code that is needed to understand this is:
function ApplicationSelect(aOwner: TComponent;
var aApplication: string): boolean;
begin
with TfrmJsApplicationSelect.Create(aOwner, aApplication) do
try
Result := ShowModal = mrOK;
finally
Release;
end;
end;
which in turn calls
constructor TfrmJsApplicationSelect.Create(aOwner: TComponent;
var aApplication: string);
begin
inherited Create(aOwner);
lApplication := aApplication;
end;
So, you are asking why the caller of ApplicationSelect does not observe any modification to aApplication when the call to ApplicationSelect returns.
You don't modify the var parameter aApplication in ApplicationSelect. You do pass it as a var parameter to TfrmJsApplicationSelect.Create but again TfrmJsApplicationSelect.Create does not modify it. Since a string variable is a value, the caller sees no modification to the variable, because it was not modified.
My other comment about ApplicationSelect is that you should call Free rather than Release.
Beyond that I could make many more comments about your code, but I will refrain from attempting a comprehensive code review and comment solely on the direct question that you asked.
In the comments you ask why changing aApplication to TStringList allows the caller to observe modifications. That's because Delphi class variables are references to the object. When you pass a TStringList variable as a parameter, you are passing a reference to the object. When you call methods on that object, any mutations are performed on the actual object.
So, how would I change this code to allow a string value to be returned? First of all I would make ApplicationSelect be a function that returns a string. In case of cancellation I would Abort.
function SelectApplication(aOwner: TComponent): string;
var
Form: TfrmJsApplicationSelect;
begin
Form := TfrmJsApplicationSelect.Create(aOwner);
try
if Form.ShowModal <> mrOK then
Abort;
Result := Form.Application;
finally
Free;
end;
end;
I would absolutely remove the global variable lApplication. You should avoid using global variables if at all possible. I'd remove every single one from the code here.
Instead add a private field to the form to hold the information:
FApplication: string;
And expose it as a public property:
property Application: string read FApplication;
Then the form merely needs to set FApplication and the caller can see that value.
I am trying to write to copy a file by invoking a separate thread.
Here is my form code:
unit frmFileCopy;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls;
type
TForm2 = class(TForm)
Button3: TButton;
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
ThreadNumberCounter : integer;
procedure HandleTerminate (Sender: Tobject);
end;
var
Form2: TForm2;
implementation
uses
fileThread;
{$R *.dfm}
{ TForm2 }
const
sourcePath = 'source\'; //'
destPath = 'dest\'; //'
fileSource = 'bigFile.zip';
fileDest = 'Copy_bigFile.zip';
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := true;
if ThreadNumberCounter >0 then
begin
if MessageDlg('The file is being copied. Do you want to quit?', mtWarning,
[mbYes, mbNo],0) = mrNo then
CanClose := false;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
ThreadNumberCounter := 0;
end;
procedure TForm2.Button3Click(Sender: TObject);
var
sourceF, destF : string;
copyFileThread : TCopyThread;
begin
sourceF := ExtractFilePath(ParamStr(0)) + sourcePath + fileSource;
destF := ExtractFilePath(ParamStr(0)) + sourcePath + fileDest;
copyFileThread := TCopyThread.create(sourceF,destF);
copyFileThread.FreeOnTerminate := True;
try
Inc(ThreadNumberCounter);
copyFileThread.Execute;
copyFileThread.OnTerminate := HandleTerminate;
copyFileThread.Resume;
except
on Exception do
begin
copyFileThread.Free;
ShowMessage('Error in thread');
end;
end;
end;
procedure TForm2.HandleTerminate(Sender: Tobject);
begin
Dec(ThreadNumberCounter);
end;
Here is my class:
unit fileThread;
interface
uses
Classes, SysUtils;
type
TCopyThread = class(TThread)
private
FIn, FOut : string;
procedure copyfile;
public
procedure Execute ; override;
constructor create (const source, dest : string);
end;
implementation
{ TCopyThread }
procedure TCopyThread.copyfile;
var
streamSource, streamDest : TFileStream;
bIn, bOut : byte;
begin
streamSource := TFileStream.Create(FIn, fmOpenRead);
try
streamDest := TFileStream.Create(FOut,fmCreate);
try
streamDest.CopyFrom(streamSource,streamSource.Size);
streamSource.Position := 0;
streamDest.Position := 0;
{check file consinstency}
while not (streamSource.Position = streamDest.Size) do
begin
streamSource.Read(bIn, 1);
streamDest.Read(bOut, 1);
if bIn <> bOut then
raise Exception.Create('files are different at position' +
IntToStr(streamSource.Position));
end;
finally
streamDest.Free;
end;
finally
streamSource.Free;
end;
end;
constructor TCopyThread.create(const source, dest: string);
begin
FIn := source;
FOut := dest;
end;
procedure TCopyThread.Execute;
begin
copyfile;
inherited;
end;
end.
When I run the application, I received a following error:
Project prjFileCopyThread raised exception class EThread with message: 'Cannot call Start on a running or suspended thread'.
I do not have experience with threads.
I use Martin Harvey's tutorial as a guide, but any advice how to improve it make safe thread would be appreciated.
Based on the answers, I've changed my code. This time it worked. I would appreciate if you can review it again and tell what should be improved.
procedure TForm2.Button3Click(Sender: TObject);
var
sourceF, destF : string;
copyFileThread : TCopyThread;
begin
sourceF := ExtractFilePath(ParamStr(0)) + sourcePath + fileSource;
destF := ExtractFilePath(ParamStr(0)) + destPath + fileDest;
copyFileThread := TCopyThread.create;
try
copyFileThread.InFile := sourceF;
copyFileThread.OutFile := destF;
except
on Exception do
begin
copyFileThread.Free;
ShowMessage('Error in thread');
end;
end;
Here is my class:
type
TCopyThread = class(TThread)
private
FIn, FOut : string;
procedure setFin (const AIN : string);
procedure setFOut (const AOut : string);
procedure FCopyFile;
protected
procedure Execute ; override;
public
constructor Create;
property InFile : string write setFin;
property OutFile : string write setFOut;
end;
implementation
{ TCopyThread }
procedure TCopyThread.FCopyfile;
var
streamSource, streamDest : TFileStream;
bIn, bOut : byte;
begin
{removed the code to make it shorter}
end;
procedure TCopyThread.setFin(const AIN: string);
begin
FIn := AIN;
end;
procedure TCopyThread.setFOut(const AOut: string);
begin
FOut := AOut;
end;
constructor TCopyThread.create;
begin
FreeOnTerminate := True;
inherited Create(FALSE);
end;
procedure TCopyThread.Execute;
begin
FCopyfile;
end;
end.
You have a few problems:
You don't call inherited Create. In this case, since you want to do things first and start it yourself, you should use
inherited Create(True); // Creates new thread suspended.
You should never call Execute yourself. It's called automatically if you create non-suspended, or if you call Resume.
There is no inherited Execute, but you call it anyway.
BTW, you could also use the built-in Windows Shell function SHFileOperation to do the copy. It will work in the background, handles multiple files and wildcards, and can automatically display progress to the user. You can probably find an example of using it in Delphi here on SO; here is a link for using it to recursively delete files, for example.
A good search here on SO is (without the quotes) shfileoperation [delphi]
Just for comparison - that's how you'd do it with OmniThreadLibrary.
uses
OtlCommon, OtlTask, OtlTaskControl;
type
TForm3 = class(TForm)
...
FCopyTask: IOmniTaskControl;
end;
procedure BackgroundCopy(const task: IOmniTask);
begin
CopyFile(PChar(string(task.ParamByName['Source'])), PChar(string(task.ParamByName['Dest'])), true);
//Exceptions in CopyFile will be mapped into task's exit status
end;
procedure TForm3.BackgroundCopyComplete(const task: IOmniTaskControl);
begin
if task.ExitCode = EXIT_EXCEPTION then
ShowMessage('Exception in copy task: ' + task.ExitMessage);
FCopyTask := nil;
end;
procedure TForm3.Button3Click(Sender: TObject);
begin
FCopyTask := CreateOmniTask(BackgroundCopy)
.SetParameter('Source', ExtractFilePath(ParamStr(0)) + sourcePath + fileSource)
.SetParameter('Dest', ExtractFilePath(ParamStr(0)) + destPath + fileDest)
.SilentExceptions
.OnTerminate(BackgroundCopyComplete)
.Run;
end;
procedure TForm3.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := true;
if assigned(FCopyTask) then
begin
if MessageDlg('The file is being copied. Do you want to quit?', mtWarning,
[mbYes, mbNo],0) = mrNo then
CanClose := false
else
FCopyTask.Terminate;
end;
end;
Your edited code still has at least two big problems:
You have a parameterless constructor, then set the source and destination file names by means of thread class properties. All you have been told about creating suspended threads not being necessary holds true only if you do all setup in the thread constructor - after this has finished thread execution will begin, and access to thread properties need to be synchronized. You should (as indeed your first version of the code did) give both names as parameters to the thread. It's even worse: the only safe way to use a thread with the FreeOnTerminate property set is to not access any property once the constructor has finished, because the thread may have destroyed itself already, or could do while the property is accessed.
In case of an exception you free the thread object, even though you have set its FreeOnTerminate property. This will probably result in a double free exception from the memory manager.
I do also wonder how you want to know when the copying of the file is finished - if there is no exception the button click handler will exit with the thread still running in the background. There is also no means of cancelling the running thread. This will cause your application to exit only when the thread has finished.
All in all you would be better off to use one of the Windows file copying routines with cancel and progress callbacks, as Ken pointed out in his answer.
If you do this only to experiment with threads - don't use file operations for your tests, they are a bad match for several reasons, not only because there are better ways to do the same in the main thread, but also because I/O bandwidth will be used best if no concurrent operations are attempted (that means: don't try to copy several files in parallel by creating several of your threads).
The Execute method of a thread is normally not explicitly called by client code. In other words: delete CopyFileThread.Execute in unit frmFileCopy. The thread is started when the Resume method is invoked.
Also in unit fileThread in the constructor of TCopyThread inherited Create(True) should be called as first to create a thread in suspended state.
You execute the thread and then trying to Resume it while it is running.
copyFileThread.Execute;
copyFileThread.OnTerminate := HandleTerminate;
copyFileThread.Resume;