I wrote this code to test how async IO cancellation works... But the read operation it's not canceled... When I call CancelSynchronousIo, the execution is blocked until thread finishes and then I get Element not found error. Do you have any idea what I did wrong ?
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TMyThread = class(TThread)
protected
procedure Execute; override;
end;
TForm1 = class(TForm)
BStartRead: TButton;
Memo1: TMemo;
BCancel: TButton;
procedure BStartReadClick(Sender: TObject);
procedure BCancelClick(Sender: TObject);
private
T1: TMyThread;
procedure LogMsg(var Msg: TMessage); message WM_USER;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TMyThread.Execute;
var Buff: TBytes;
hFile: THandle;
StrMsg, FileName: String;
N: Cardinal;
begin
SetLength(Buff, 200000000);
FileName:= '...some file...';
hFile:= CreateFile(PChar('\\?\'+FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hFile <> INVALID_HANDLE_VALUE then begin
StrMsg:= 'Start reading...'; SendMessage(Form1.Handle, WM_USER, WPARAM(#StrMsg), 0);
if ReadFile(hFile, Buff[0], 200000000, N, nil)
then StrMsg:= 'Successfuly terminated.'
else StrMsg:= 'Error: canceled !';
SendMessage(Form1.Handle, WM_USER, WPARAM(#StrMsg), 0);
CloseHandle(hFile);
end
else begin
StrMsg:= 'Error: failed to open file !';
SendMessage(Form1.Handle, WM_USER, WPARAM(#StrMsg), 0);
end;
end;
//---- VCL -----
procedure TForm1.BStartReadClick(Sender: TObject);
begin
T1:= TMyThread.Create;
end;
procedure TForm1.BCancelClick(Sender: TObject);
begin
if CancelSynchronousIo(T1.Handle) then Memo1.Lines.Add('Cancel result: success')
else Memo1.Lines.Add('Cancel result: '+SysErrorMessage(GetLastError));
end;
procedure TForm1.LogMsg(var Msg: TMessage);
begin
case Msg.Msg of
WM_USER: Memo1.Lines.Add(PString(Msg.WParam)^.Substring(0));
end;
end;
end.
Related
This is the first time to try working with Threads, I'm trying to copy a directory using a Thread, so here is what I did (After I read this post):
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.IOUtils, System.Types;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMyThread= class(TThread)
private
Fsource, FDest: String;
protected
public
constructor Create(Const Source, Dest: string);
destructor Destroy; override;
procedure Execute(); override;
published
end;
var
Form1: TForm1;
MT: TMyThread;
implementation
{$R *.dfm}
{ TMyThread }
constructor TMyThread.Create(const Source, Dest: string);
begin
Fsource:= Source;
FDest:= Dest;
end;
destructor TMyThread.Destroy;
begin
inherited;
end;
procedure TMyThread.Execute;
var Dir: TDirectory;
begin
inherited;
try
Dir.Copy(Fsource, FDest);
except on E: Exception do
ShowMessage(E.Message);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MT := TMyThread.Create('SourceFolder', 'DestinationFolder');
try
MT.Execute;
finally
MT.Free;
end;
end;
end.
When I click on the Button1 I get this error message:
Cannot call Start on a running or suspended thread
What's wrong here? I don't know much about threads,I even try:
MT := TMyThread.Create('SourceFolder', 'DestinationFolder');
Thanks for all guys helps with helpful comments:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.IOUtils, System.Types;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMyThread= class(TThread)
private
Fsource, FDest: String;
protected
public
constructor Create(Const Source, Dest: string);
destructor Destroy; override;
procedure Execute(); override;
published
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TMyThread }
constructor TMyThread.Create(const Source, Dest: string);
begin
inherited Create;
Fsource:= Source;
FDest:= Dest;
Self.FreeOnTerminate := True;
end;
destructor TMyThread.Destroy;
begin
inherited;
end;
procedure TMyThread.Execute;
begin
try
TDirectory.Copy(Fsource, FDest);
except on E: Exception do
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var MT: TMyThread;
begin
MT := TMyThread.Create('Source', 'Destination');
end;
end.
i have this TThread that i use inside my dll to update some visual control its working fine but i face issue when i try to close my dll and reopen it again its raised this exception
checksynchronize called from thread which is not the main thread
what iam doing wrong ? i need to call checksynchronize within timer because i will update some vcl with Threading while app running .
Here is my Thread unit
unit Thread;
interface
uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
ShlObj;
{ Thread client }
type
TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;
TAPPTHREAD = class(TThread)
private
Fstatus : String;
FOnCallbackProc: TThreadCallbackProc;
procedure dosomework;
procedure DoCallbackProc;
//
protected
procedure Execute; override;
Public
constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
destructor Destroy; override;
end;
var
APPTHREAD : TAPPTHREAD;
implementation
constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
aThreadCallbackProc: TThreadCallbackProc);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FOnCallbackProc := aThreadCallbackProc;
end;
destructor TAPPTHREAD.Destroy;
begin
//
end;
procedure TAPPTHREAD.DoCallbackProc;
begin
if Assigned(FOnCallbackProc) then
FOnCallbackProc(self, Fstatus);
end;
procedure TAPPTHREAD.Execute;
begin
while not Terminated do
begin
Fstatus := 'Synched';
if Fstatus <> '' then
dosomework;
end;
end;
procedure TAPPTHREAD.dosomework;
begin
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
end.
Main Form
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;
type
TForm1 = class(TForm)
Label1: TLabel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure callbackproc(Sender: TObject; Updatestring : String);
end;
var
Form1: TForm1;
implementation
uses Thread;
{$R *.dfm}
procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;
try
Timer2.Enabled := False;
except end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;
end.
DFM
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 242
ClientWidth = 472
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 0
Top = 0
Width = 472
Height = 13
Align = alTop
Caption = 'Label1'
ExplicitLeft = 232
ExplicitTop = 136
ExplicitWidth = 31
end
object Timer1: TTimer
Enabled = False
OnTimer = Timer1Timer
Left = 232
Top = 128
end
object Timer2: TTimer
Enabled = False
Interval = 1
OnTimer = Timer2Timer
Left = 320
Top = 168
end
end
dll code
library dllapp;
uses
System.SysUtils,
Themes,
Windows,
Forms,
dialogs,
Graphics,
Vcl.ExtCtrls,
Unit1 in 'Unit1.pas' {Unit1},
DThreadsend in 'Thread.pas';
var
mHandle: THandle;
DLLHandle: Longint = 0;
function createApp(Width: Integer; Height: Integer; hw: HWnd;
app: TApplication): boolean; stdcall;
begin
mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Halt;
end;
try
form1 := Tform1.CreateParented(hw); // **
form1.Width := Width;
form1.Height := Height;
Result := True
except
on e: exception do
begin
Result := False;
end;
end;
end;
procedure closeApp; stdcall;
begin
ApplicationClosed := True;
try
if mHandle <> 0 then
CloseHandle(mHandle);
except
end;
if Assigned(form1) then
try
FreeAndNil(form1);
except
end;
try
OptimizeRamUsage;
except
end;
end;
procedure showapp; stdcall;
begin
try
form1.Visible := True;
except
end;
form1.Show;
end;
procedure DLLEntryProc(EntryCode: Integer);
begin
case EntryCode of
DLL_PROCESS_DETACH:
begin
StyleServices.Free;
end;
DLL_PROCESS_ATTACH:
begin
end;
DLL_THREAD_ATTACH:
begin
end;
DLL_THREAD_DETACH:
begin
end;
end;
end;
exports
closeApp,
createApp,
showapp;
begin
DllProc := #DLLEntryProc;
end.
Host Application and how i create Dll
loadapp Unit
unit loadapp;
interface
uses windows, forms, System.SysUtils , dialogs;
procedure loadmainapp;
type
TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
TshowFunc = procedure stdcall;
TCloseAppFunc = procedure stdcall;
var
dllHandle : THandle = 0;
creaFunc : TcreaFunc;
showFunc : TshowFunc;
CloseAppFunc: TCloseAppFunc;
implementation
uses Mainapp;
procedure loadmainapp;
var
S: widestring;
PW: PWideChar;
begin
S := 'dllapp.dll';
pw:=pwidechar(widestring(s));
dllHandle := LoadLibrary(pw);
if dllHandle <> 0 then
begin
#creaFunc := GetProcAddress(dllHandle, 'createApp');
#showFunc := GetProcAddress(dllHandle, 'showapp');
if Assigned (creaFunc) then
begin
creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
DisFunc;
end
else
ShowMessage('ERROR');
end
else
begin
ShowMessage('ERROR');
end;
end;
end.
Active Form
unit activeform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;
type
TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
mpanl: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
end;
implementation
uses ComObj, ComServ, Mainapp, libacload;
{$R *.DFM}
{ TActiveFrmldr }
procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
#CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle); //release dll
end;
if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;
end;
procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;
procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFrmldr,
Class_ActiveFrmldr,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
finalization
end.
Main app Form that call load library function
unit Mainapp;
interface
uses
Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
Vcl.Controls, Vcl.StdCtrls;
type
Tmainfrm = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
mainfrm: Tmainfrm;
implementation
Uses loadapp;
{$R *.dfm}
procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
loadmainapp;
end;
procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin
checksynchronize; // i do this to check some thread in activex it self
end;
end.
The error means that CheckSynchronize() is being called in a thread whose ThreadID does not match the RTL's global System.MainThreadID variable.
A DLL does not have a main thread of its own. MainThreadID gets initialized to whatever thread is initializing the DLL. So, if your DLL is creating its GUI in a different thread than the one that is initializing your DLL, CheckSynchronize() (and TThread.Synchronize(), and TThread.Queue()) will not work unless you manually update the MainThreadID variable to the ThreadID that is running your GUI. Do that before creating your worker thread, eg:
if IsLibrary then
MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);
Or:
procedure TForm1.FormCreate(Sender: TObject);
begin
if IsLibrary then
MainThreadID := GetCurrentThreadID;
end;
Or:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
if IsLibrary then
MainThreadID := GetCurrentThreadID;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
I want to terminate thread by clicking the button. If the thread normally works without user interruption it is OK but sometimes user needs to abort thread and that's the question that how user abort the thread.
Here is my code that I tested:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, mmsystem, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
procedure Image1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
type
hangth = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
procedure play;
end;
var
Form1: TForm1;
played: boolean;
szalhang: hangth;
implementation
{$R *.dfm}
procedure hangth.play;
begin
played := true;
szalhang.Terminate;
end;
procedure hangth.Execute;
begin
played := false;
SndPlaySound(pchar('hang.wav'), SND_SYNC);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
played := true;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if played = true then begin
szalhang := hangth.Create(true);
szalhang.Resume;
end else begin
szalhang.Terminate();
// here i want to terminate thread, but it doesn't want to be killed.
end;
end;
end.
When you call TThread.Terminate(), it sets the TThread.Terminated property to true and does nothing else. It is the responsibility of your TThread.Execute() code to look at the TThread.Terminated property periodically and exit gracefully when it is True. However, in this situation, that is not possible because SndPlaySound() is blocking the thread, and there is no way to interrupt SndPlaySound() when it is running in SND_SYNC mode. Your only option would be to use the Win32 API TerminateThread() function to perform a brute-force termination of the thread.
Since you obviously need more control over the playback of the audio, and detection of when the audio is finished playing, then SndPlaySound() is not the best solution for your needs. You have a TForm, you might consider using Delphi's TMediaPlayer component, for example:
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, Vcl.MPlayer;
type
MPlayerState = (mpsClosed, mpsOpened, mpsPlaying);
TForm1 = class(TForm)
Image1: TImage;
MediaPlayer1: TMediaPlayer;
procedure MediaPlayer1Notify(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Image1Click(Sender: TObject);
private
{ Private declarations }
State: MPlayerState;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm56.FormCreate(Sender: TObject);
begin
State := mpsClosed;
MediaPlayer1.FileName := 'C:\full path to\hang.wav';
end;
procedure TForm56.MediaPlayer1Notify(Sender: TObject);
begin
case MediaPlayer1.Mode of
mpStopped, mpPlaying:
State := mpsOpened;
end;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if State = mpsClosed then
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Open;
State := mpsOpened;
end;
if State = mpsOpened then
begin
MediaPlayer1.Notify := True;
MediaPlayer1.Wait := False;
MediaPlayer1.Play;
if MediaPlayer1.Error = 0 then
State := mpsPlaying
end else
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Stop;
State := mpsOpened;
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Close;
State := mpsClosed;
end;
end;
end.
Original Question
In our Delphi XE4 application we use a TOmniEventMonitor to receive messages from other tasks. As long as this is running in the main thread, it works fine, but once I put the same code in a task, the TOmniEventMonitor stops receiving messages. I have included a simple example of this below -- clicking Button_TestInMainThread results in a file being written as expected, clicking Button_TestInBackgroundThread does not. Is this by design, or is there some way to get this working while still using TOmniEventMonitor?
unit mainform;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
OtlTask, OtlTaskControl, OtlComm, OtlEventMonitor;
const
MY_OMNI_MESSAGE = 134;
type
TOmniEventMonitorTester = class(TObject)
fName : string;
fOmniEventMonitor : TOmniEventMonitor;
fOmniTaskControl : IOmniTaskControl;
constructor Create(AName : string);
destructor Destroy(); override;
procedure HandleOmniTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
end;
TTestLauncherTask = class(TOmniWorker)
fOmniTaskMonitorTester : TOmniEventMonitorTester;
function Initialize() : boolean; override;
end;
TForm1 = class(TForm)
Button_TestInMainThread: TButton;
Button_TestInBackgroundThread: TButton;
procedure Button_TestInMainThreadClick(Sender: TObject);
procedure Button_TestInBackgroundThreadClick(Sender: TObject);
private
fOmniEventMonitorTester : TOmniEventMonitorTester;
fTestLauncherTask : IOmniTaskControl;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure OmniTaskProcedure_OneShotTimer(const task: IOmniTask);
begin
Sleep(1000);
task.Comm.Send(MY_OMNI_MESSAGE);
end;
constructor TOmniEventMonitorTester.Create(AName : string);
begin
inherited Create();
fName := AName;
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleOmniTaskMessage;
fOmniTaskControl := fOmniEventMonitor.Monitor(CreateTask(OmniTaskProcedure_OneShotTimer)).Run();
end;
destructor TOmniEventMonitorTester.Destroy();
begin
fOmniEventMonitor.Free();
inherited Destroy();
end;
procedure TOmniEventMonitorTester.HandleOmniTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + fName + '.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, fName);
CloseFile(F);
end;
function TTestLauncherTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniTaskMonitorTester := TOmniEventMonitorTester.Create('background');
end;
end;
procedure TForm1.Button_TestInMainThreadClick(Sender: TObject);
begin
fOmniEventMonitorTester := TOmniEventMonitorTester.Create('main');
end;
procedure TForm1.Button_TestInBackgroundThreadClick(Sender: TObject);
begin
fTestLauncherTask := CreateTask(TTestLauncherTask.Create()).Run();
end;
end.
Additional Observations
With the following code it seems to be possible to successfully use a TOmniEventMonitor within a background thread. This really is a very clumsy solution -- an IOmniTwoWayChannel gets created but not used in any meaningful way -- but as soon as I try to simplify the code by commenting out either of the lines marked "don't remove!", HandleTaskMessage doesn't get called any more. Can anybody tell me what I am doing wrong here?
unit mainform;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
DSiWin32, GpLists, OtlTask, OtlTaskControl, OtlCommon, OtlComm, OtlEventMonitor;
const
MY_OMNI_MESSAGE = 134;
type
TOmniEventMonitorTestTask = class(TOmniWorker)
fOmniTaskControl : IOmniTaskControl;
fOmniTwoWayChannel : IOmniTwoWayChannel;
fOmniEventMonitor : TOmniEventMonitor;
function Initialize() : boolean; override;
procedure HandleTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
procedure HandleTaskTerminated(const task: IOmniTaskControl);
end;
TForm1 = class(TForm)
Button_TestInBackgroundThread: TButton;
procedure Button_TestInBackgroundThreadClick(Sender: TObject);
private
fTestTask : IOmniTaskControl;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure OmniTaskProcedure_OneShotTimer(const task: IOmniTask);
begin
Sleep(1000);
task.Comm.Send(MY_OMNI_MESSAGE); // don't remove!
(task.Param['Comm'].AsInterface as IOmniCommunicationEndpoint).Send(MY_OMNI_MESSAGE);
end;
procedure TOmniEventMonitorTestTask.HandleTaskMessage(const task: IOmniTaskControl; const msg: TOmniMessage);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + 'HandleTaskMessage.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, 'HandleTaskMessage!');
CloseFile(F);
end;
procedure TOmniEventMonitorTestTask.HandleTaskTerminated(const task: IOmniTaskControl);
var
Filename : string;
F : TextFile;
begin
Filename := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0))) + 'HandleTaskTerminated.txt';
AssignFile(F, Filename);
Rewrite(F);
Writeln(F, 'HandleTaskTerminated!');
CloseFile(F);
end;
function TOmniEventMonitorTestTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleTaskMessage;
fOmniEventMonitor.OnTaskTerminated := HandleTaskTerminated;
fOmniTwoWayChannel := CreateTwoWayChannel();
Task.RegisterComm(fOmniTwoWayChannel.Endpoint1); // don't remove!
fOmniTaskControl := fOmniEventMonitor.Monitor( CreateTask(OmniTaskProcedure_OneShotTimer) ).SetParameter('Comm', fOmniTwoWayChannel.Endpoint2).Run();
end;
end;
procedure TForm1.Button_TestInBackgroundThreadClick(Sender: TObject);
begin
fTestTask := CreateTask(TOmniEventMonitorTestTask.Create()).Run();
end;
end.
There is no problem with TOmniEventMonitor running inside of a thread, provided there is a message pump handling the messages for it. I put this block of code together to demonstrate. This works as expected.
procedure TMyThread.Execute;
var
Message: TMsg;
begin
FreeOnTerminate := True;
fOmniEventMonitor := TOmniEventMonitor.Create(nil);
fOmniEventMonitor.OnTaskMessage := HandleOmniTaskMessage;
fOmniTaskControl := fOmniEventMonitor.Monitor(CreateTask(OmniTaskProcedure_OneShotTimer)).Run();
try
while not Terminated do
begin
if MsgWaitForMultipleObjects(0, nil^, False, 1000, QS_ALLINPUT) = WAIT_OBJECT_0 then
begin
while PeekMessage(Message, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
end;
end;
finally
fOmniTaskControl := nil;
fOmniEventMonitor.Free;
end;
end;
From what I can see, the TOmniTaskExecutor waits for messages to specific handles. In your code example, it's the terminate event and a couple of comm handles. The messages for the TOmniEventMonitor are never processed.
Changing your TTestLauncherTask.Initialize to the following results in it correctly writing out the file. DoNothingProc is just an empty method on the class.
function TTestLauncherTask.Initialize() : boolean;
begin
result := inherited Initialize();
if result then begin
fOmniTaskMonitorTester := TOmniEventMonitorTester.Create('background');
// Tell the task about the event monitor
Task.RegisterWaitObject(fOmniTaskMonitorTester.fOmniEventMonitor.MessageWindow, DoNothingProc);
end;
end;
I am adding the message window for the TOmniEventMonitor to the Task WaitObject list so the handle is then registered with the MsgWaitForMultipleObjectsEx call and waiting for Remi and David to tear my message handling to shreds :)
When program starts, automatically downloads given EXE file, but if I want to abort the current process and restart to download again or/and if EXE is downloaded successfully one time and would like to download again, program stops with error message: "raised exception class EIdHTTPProtocolException"
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,idhttp, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
ProgressBar1: TProgressBar;
IdHTTP1: TIdHTTP;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Integer);
procedure IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure DownloadFile;
end;
type
xy = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
procedure friss;
end;
var
Form1: TForm1;
szal:xy;
Stream: TMemoryStream;
implementation
{$R *.dfm}
procedure xy.friss;
begin
ShowMessage('kész');
szal.terminate;
end;
procedure TForm1.Button1Click(Sender: TObject); //abort
begin
szal.Suspend;
szal.Terminate;
end;
procedure TForm1.Button2Click(Sender: TObject); //restart
begin
szal:=xy.Create(true);
szal.Resume;
end;
procedure tform1.DownloadFile;
var
Url, FileName: String;
begin
idhttp1:=idhttp1.Create(self);
Url := 'http://livecd.com/downloads/ActiveDataStudioSetup.exe';
Filename := 'c:\setup.zip';
Stream := TMemoryStream.Create;
try
IdHTTP1.Get(Url, Stream);
Stream.SaveToFile(FileName);
finally
Stream.Free;
IdHTTP1.free;
end;
end;
procedure xy.execute;
begin
form1.DownloadFile;
Synchronize(friss);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
szal:=xy.Create(true);
szal.Resume;
end;
procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
begin
form1.ProgressBar1.Position:=AWorkCount;
end;
procedure TForm1.IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Integer);
begin
form1.ProgressBar1.Max:=AWorkCountMax;
form1.ProgressBar1.Position:=0;
end;
end.
Source code: http://pastebin.com/9DvSyTD7
Project: http://osztott.com/ubXN/cucc.zip
EIdHTTPProtocolException means the HTTP server sent back an error, such as if the requested resource is not found or cannot be accessed. That has nothing to do with your threading logic.
However, there are a lot of problems with your code in general - misuse of TThread and dynamic components, not syncing the worker thread with the main UI thread, etc.
Try something more like this instead:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
ProgressBar1: TProgressBar;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure StartDownload;
procedure StopDownload;
procedure DownloadFinished(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
uses
IdHTTP, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdSync;
{$R *.dfm}
type
TDownloadThread = class(TThread)
private
{ Private declarations }
procedure HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Integer);
procedure HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer);
protected
procedure Execute; override;
public
property ReturnValue;
property Terminated;
end;
TDownloadStatusNotify = class(TIdNotify)
protected
Value: Integer;
DownloadBegin: Boolean;
procedure DoNotify; override;
public
constructor Create(AValue: Integer: ADownloadBegin: Boolean); reintroduce;
end;
TFreeDownloadThreadNotify = class(TIdNotify)
protected
Thread: TDownloadThread;
procedure DoNotify; override;
public
constructor Create(AThread: TDownloadThread); reintroduce;
end;
procedure TDownloadThread.Execute;
var
Url, Filename: string;
HTTP: TIdHTTP;
Stream: TMemoryStream;
begin
Url := 'http://livecd.com/downloads/ActiveDataStudioSetup.exe';
Filename := 'c:\setup.zip';
HTTP := TIdHTTP.Create(nil);
try
HTTP.OnWorkBegin := HTTPWorkBegin;
HTTP.OnWork := HTTPWork;
Stream := TMemoryStream.Create;
try
HTTP.Get(Url, Stream);
Stream.SaveToFile(Filename);
finally
Stream.Free;
end;
finally
HTTP.Free;
end;
ReturnValue := 1;
end;
procedure TDownloadThread.HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Integer);
begin
if Terminated then SysUtils.Abort;
if AWorkMode = wmRead then
TDownloadStatusNotify.Create(AWorkCountMax, True).Notify;
end;
procedure TDownloadThread.HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer);
begin
if Terminated then SysUtils.Abort;
if AWorkMode = wmRead then
TDownloadStatusNotify.Create(AWorkCount, False).Notify;
end;
constructor TDownloadStatusNotify.Create(AValue: Integer; ADownloadBegin: Boolean);
begin
inherited Create;
Value := AValue;
DownloadBegin := ADownloadBegin;
end;
procedure TDownloadStatusNotify.DoNotify;
begin
if DownloadBegin then
begin
Form1.ProgressBar1.Position := 0;
Form1.ProgressBar1.Max := Value;
end else
begin
if Form1.ProgressBar1.Max > 0 then
begin
Form1.ProgressBar1.Position := Value;
end else
begin
// the download size is unknown (most likely chunked) so
// display the current Value somewhere else...
end;
end;
end;
constructor TFreeDownloadThreadNotify.Create(AThread: TDownloadThread);
begin
inherited Create;
MainThreadUsesNotify := True;
Thread := AThread;
end;
procedure TFreeDownloadThreadNotify.DoNotify;
begin
Thread.Free;
end;
var
szal: TDownloadThread = nil;
procedure TForm1.FormCreate(Sender: TObject);
begin
StartDownload;
end;
procedure TForm1.Button1Click(Sender: TObject); //abort
begin
StopDownload;
end;
procedure TForm1.Button2Click(Sender: TObject); //restart
begin
StopDownload;
StartDownload;
end;
procedure TForm1.StartDownload;
begin
szal := TDownloadThread.Create(True);
sza1.OnTerminate := DownloadFinished;
szal.Resume;
end;
procedure TForm1.StopDownload;
begin
if sza1 <> nil then
begin
szal.Terminate;
sza1.WaitFor;
FreeAndNil(sza1);
end;
end;
procedure TForm1.DownloadFinished(Sender: TObject);
begin
if sza1.ReturnValue = 1 then
ShowMessage('kész')
else if sza1.Terminated then
ShowMessage('félbeszakadt')
else
ShowMessage('hiba');
if not sza1.Terminated then
begin
TFreeDownloadThreadNotify.Create(sza1).Notify;
sza1 := nil;
end;
end;
end.