Delphi OmniThreadLibrary 3.03b:IBackgroundWorker - 终止不起作用
Delphi OmniThreadLibrary 3.03b: IBackgroundWorker - Termination doesn't work
我在 OmniThreadLibrary 中终止 BackgroundWorker 时遇到问题。一切正常,但是当我想终止 BackgroundWorker 时,终止失败,BackgroundWorker 仍然存在。因此,运行 作为批处理的整个应用程序仍然存在。
procedure TEntityIndexer.StartReindex;
begin
if LoadTable then
begin
// In a ProcessRecords method I schedule WorkItems for background tasks
ProcessRecords;
while FCounter > 0 do
ProcessMessages;
// In ProcessMessages I keep the main thread alive
ProcessRecordsContinue;
// In ProcessRecordsContinue method I process the results of background tasks and OnRequestDone method
end
else
TerminateBackgroundWorker;
end;
procedure ProcessMessages;
var
Msg: TMsg;
begin
while integer(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) <> 0 do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
constructor TEntityIndexer.Create;
begin
...
CreateBackgroundWorker;
end;
procedure TEntityIndexer.CreateBackgroundWorker;
begin
FBackgroundWorker := Parallel.BackgroundWorker
.NumTasks(INITasksCount)
.Initialize(InitializeTask)
.Finalize(FinalizeTask)
.OnRequestDone(HandleRequestDone)
.Execute(ProcessSupportStrings);
end;
procedure TEntityIndexer.FinalizeTask(const taskState: TOmniValue);
var
_obj: TObject;
begin
if not(taskState.IsObject) then
Exit;
_obj := taskState.AsObject;
if _obj is TServerSessionApp then
TServerSessionApp(_obj).ParentApplication.Free;
CoUninitialize;
end;
procedure TEntityIndexer.ProcessRecordsContinue;
begin
if FStack.Count = 0 then
Exit;
...
FStack.Clear;
StartReindex;
end;
procedure TEntityIndexer.ProcessRecords;
...
begin
FVTable.First;
while not FVTable.Eof do
begin
...
_omniValue := TOmniValue.CreateNamed(
[ovIdKey, _id,
ovXMLKey, FVTable.FieldByName('mx').AsString,
ovGenKey, FVTable.FieldByName('created').AsString
]);
FBackgroundWorker.Schedule(FBackgroundWorker.CreateWorkItem(_omniValue));
Inc(FCounter);
FVTable.Next;
end;
end;
procedure TEntityIndexer.ProcessSupportStrings(const workItem: IOmniWorkItem);
var
...
begin
if not(workItem.taskState.IsObject) then
...
if not workItem.Data.IsArray then
raise Exception.Create('Empty parameters!');
...
// make some JSON and XML strings
...
try
try
workItem.Result := TOmniValue.CreateNamed(
[... ]);
...
end;
procedure TEntityIndexer.HandleRequestDone(const Sender: IOmniBackgroundWorker;
const workItem: IOmniWorkItem);
var
...
begin
Dec(FCounter);
if workItem.IsExceptional then
begin
// Process the exception
end
else if workItem.Result.IsArray then
begin
...
FStack.AddToStack(_stackItem);
end;
end;
procedure TEntityIndexer.InitializeTask(var taskState: TOmniValue);
begin
CoInitialize(nil);
taskState.AsObject := CreateAnotherServerSession;
end;
procedure TEntityIndexer.TerminateBackgroundWorker;
begin
// Here is s problem - Termination of the BackgroundWorker doesn't work, but finalization
// of background tasks is done
FBackgroundWorker.Terminate(INFINITE);
FBackgroundWorker := nil;
end;
end.
好的,我发现了一个错误。这不是OTL的错误。这是由于 Finalize() 方法中对象的错误销毁引起的。释放 taskState 参数变量中的对象还不够。 TaskState 参数变量也应该被清除。
procedure TEntityIndexer.FinalizeTask(const taskState: TOmniValue);
var
_obj: TObject;
begin
if not(taskState.IsObject) then
Exit;
_obj := taskState.AsObject;
if Assigned(_obj) then
_obj.Free;
if _obj is TServerSessionApp then
TServerSessionApp(_obj).ParentApplication.Free;
// release the objects and clear a taskState variable
taskState.Clear;
CoUninitialize;
end;
我在 OmniThreadLibrary 中终止 BackgroundWorker 时遇到问题。一切正常,但是当我想终止 BackgroundWorker 时,终止失败,BackgroundWorker 仍然存在。因此,运行 作为批处理的整个应用程序仍然存在。
procedure TEntityIndexer.StartReindex;
begin
if LoadTable then
begin
// In a ProcessRecords method I schedule WorkItems for background tasks
ProcessRecords;
while FCounter > 0 do
ProcessMessages;
// In ProcessMessages I keep the main thread alive
ProcessRecordsContinue;
// In ProcessRecordsContinue method I process the results of background tasks and OnRequestDone method
end
else
TerminateBackgroundWorker;
end;
procedure ProcessMessages;
var
Msg: TMsg;
begin
while integer(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) <> 0 do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
constructor TEntityIndexer.Create;
begin
...
CreateBackgroundWorker;
end;
procedure TEntityIndexer.CreateBackgroundWorker;
begin
FBackgroundWorker := Parallel.BackgroundWorker
.NumTasks(INITasksCount)
.Initialize(InitializeTask)
.Finalize(FinalizeTask)
.OnRequestDone(HandleRequestDone)
.Execute(ProcessSupportStrings);
end;
procedure TEntityIndexer.FinalizeTask(const taskState: TOmniValue);
var
_obj: TObject;
begin
if not(taskState.IsObject) then
Exit;
_obj := taskState.AsObject;
if _obj is TServerSessionApp then
TServerSessionApp(_obj).ParentApplication.Free;
CoUninitialize;
end;
procedure TEntityIndexer.ProcessRecordsContinue;
begin
if FStack.Count = 0 then
Exit;
...
FStack.Clear;
StartReindex;
end;
procedure TEntityIndexer.ProcessRecords;
...
begin
FVTable.First;
while not FVTable.Eof do
begin
...
_omniValue := TOmniValue.CreateNamed(
[ovIdKey, _id,
ovXMLKey, FVTable.FieldByName('mx').AsString,
ovGenKey, FVTable.FieldByName('created').AsString
]);
FBackgroundWorker.Schedule(FBackgroundWorker.CreateWorkItem(_omniValue));
Inc(FCounter);
FVTable.Next;
end;
end;
procedure TEntityIndexer.ProcessSupportStrings(const workItem: IOmniWorkItem);
var
...
begin
if not(workItem.taskState.IsObject) then
...
if not workItem.Data.IsArray then
raise Exception.Create('Empty parameters!');
...
// make some JSON and XML strings
...
try
try
workItem.Result := TOmniValue.CreateNamed(
[... ]);
...
end;
procedure TEntityIndexer.HandleRequestDone(const Sender: IOmniBackgroundWorker;
const workItem: IOmniWorkItem);
var
...
begin
Dec(FCounter);
if workItem.IsExceptional then
begin
// Process the exception
end
else if workItem.Result.IsArray then
begin
...
FStack.AddToStack(_stackItem);
end;
end;
procedure TEntityIndexer.InitializeTask(var taskState: TOmniValue);
begin
CoInitialize(nil);
taskState.AsObject := CreateAnotherServerSession;
end;
procedure TEntityIndexer.TerminateBackgroundWorker;
begin
// Here is s problem - Termination of the BackgroundWorker doesn't work, but finalization
// of background tasks is done
FBackgroundWorker.Terminate(INFINITE);
FBackgroundWorker := nil;
end;
end.
好的,我发现了一个错误。这不是OTL的错误。这是由于 Finalize() 方法中对象的错误销毁引起的。释放 taskState 参数变量中的对象还不够。 TaskState 参数变量也应该被清除。
procedure TEntityIndexer.FinalizeTask(const taskState: TOmniValue);
var
_obj: TObject;
begin
if not(taskState.IsObject) then
Exit;
_obj := taskState.AsObject;
if Assigned(_obj) then
_obj.Free;
if _obj is TServerSessionApp then
TServerSessionApp(_obj).ParentApplication.Free;
// release the objects and clear a taskState variable
taskState.Clear;
CoUninitialize;
end;