'MyThread' does not run. I do not know whether the problem happens on 'DataTransferServiceStart' procedure. I guess the 'DataTransferServiceStart' procedure does not execute. IDE is Delphi XE. Please help me, thank you very much.
Thread's Unit:
unit Unit_MyThread;
interface
uses
Classes, SysUtils;
type
TMyThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
implementation
procedure TMyThread.Execute;
var
log: TextFile;
logPath: String;
i: Integer;
begin
logPath := 'd:\test.log';
AssignFile(log, logPath);
Append(log);
i := 0;
while not self.Terminated do
begin
Sleep(1);
Writeln(log, IntToStr(i));
if i=10 then
Terminate;
i := i + 1;
end;
CloseFile(log);
end;
end.
Main Service Unit:
unit Unit_main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
ExtCtrls, DB, ADODB, Unit_MyThread;
type
TDataTransferService = class(TService)
DBSrc: TADOConnection;
procedure DataTransferServiceStart(Sender: TService; var Started: Boolean);
procedure DataTransferServiceContinue(Sender: TService; var Continued: Boolean);
procedure DataTransferServicePause(Sender: TService; var Paused: Boolean);
procedure DataTransferServiceStop(Sender: TService; var Stopped: Boolean);
public
function GetServiceController: TServiceController; override;
end;
var
DataTransferService: TDataTransferService;
MyThread: TMyThread;
implementation
{$R *.DFM}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
DataTransferService.Controller(CtrlCode);
end;
function TDataTransferService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TDataTransferService.DataTransferServiceStart(Sender: TService;
var Started: Boolean);
begin
MyThread := TMyThread.Create(False);
Started := True;
end;
procedure TDataTransferService.DataTransferServiceContinue(Sender: TService;
var Continued: Boolean);
begin
MyThread.Start;
Continued := True;
end;
procedure TDataTransferService.DataTransferServicePause(Sender: TService;
var Paused: Boolean);
begin
MyThread.Suspended := true;
Paused := True;
end;
procedure TDataTransferService.DataTransferServiceStop(Sender: TService;
var Stopped: Boolean);
begin
MyThread.Terminate;
Stopped := True;
end;
end.
Your service is most likely failing to start because you have a TADOConnection component dropped into your service. You cannot do this in services. Since ADO is COM, you must initialize each thread with CoInitialize(nil) and CoUninitialize, and only create/use your database components within this.
uses
ActiveX;
procedure TDataTransferService.DataTransferServiceStart(Sender: TService;
var Started: Boolean);
begin
CoInitialize(nil);
DBSrc:= TADOConnection.Create(nil);
//Initialize and Connect DBSrc
MyThread := TMyThread.Create(False);
Started := True;
end;
procedure TDataTransferService.DataTransferServiceStop(Sender: TService;
var Stopped: Boolean);
begin
MyThread.Terminate;
//Disconnect DBSrc
DBSrc.Free;
CoUninitialize;
Stopped := True;
end;
Read here: Ok to use TADOConnection in threads
Related
I have a small Windows software created with Delphi 7 where a thread periodically do some action, like save information in a SQLite database. It works just fine, but the same thread never execute when Windows is about to shutdown/reboot/logoff. Here is a simple example:
type
TSaveText = class(TThread)
private
FText: string;
protected
procedure Execute; override;
end;
...
private
procedure WMQueryEndSession(var AMsg: TMessage); message WM_QUERYENDSESSION;
procedure SaveText(const AText: string);
...
procedure AddToLog(const Str: string);
var
Pth: string;
Txt: TextFile;
begin
Pth := ExtractFilePath(ParamStr(0)) + 'log.txt';
try
AssignFile(Txt, Pth);
if not FileExists(Pth) then
ReWrite(Txt);
Append(Txt);
WriteLn(Txt, Trim(Str));
finally
CloseFile(Txt);
end;
end;
procedure TfrmMain.SaveText(const AText: String);
begin
with TSaveText.Create(True) do
begin
FText := AText;
FreeOnTerminate := True;
Priority := tpNormal;
Resume;
end;
end;
procedure TSaveText.Execute;
begin
inherited;
AddToLog(FText);
end;
procedure TfrmMain.WMQueryEndSession(var AMsg: TMessage);
begin
inherited;
SaveText('Windows is about to shutdown/reboot/logoff!');
AMsg.Result := 1;
end;
In this example, the text 'Windows is about to shutdown/reboot/logoff!' is never saved in the log file. But if I remove the action from the thread, it works:
procedure TfrmMain.WMQueryEndSession(var AMsg: TMessage);
begin
inherited;
AddToLog('Windows is about to shutdown/reboot/logoff!');
AMsg.Result := 1;
end;
I'd like to know if there is a way to force thread to execute in this scenario, when Windows is about to shutdown/reboot/logoff.
Thanks!
I created a class for writing thread-safe log in a text file using CriticalSection.
I am not an expert of CriticalSection and multi-threading programming (...and Delphi), I'm definitely doing something wrong...
unit ErrorLog;
interface
uses
Winapi.Windows, System.SysUtils;
type
TErrorLog = class
private
FTextFile : TextFile;
FLock : TRTLCriticalSection;
public
constructor Create(const aLogFilename:string);
destructor Destroy; override;
procedure Write(const ErrorText: string);
end;
implementation
constructor TErrorLog.Create(const aLogFilename:string);
begin
inherited Create;
InitializeCriticalSection(FLock);
AssignFile(FTextFile, aLogFilename);
if FileExists(aLogFilename) then
Append(FTextFile)
else
Rewrite(FTextFile);
end;
destructor TErrorLog.Destroy;
const
fmTextOpenWrite = 55218;
begin
EnterCriticalSection(FLock);
try
if TTextRec(FTextFile).Mode <> fmTextOpenWrite then
CloseFile(FTextFile);
inherited Destroy;
finally
LeaveCriticalSection(FLock);
DeleteCriticalSection(FLock);
end;
end;
procedure TErrorLog.Write(const ErrorText: string);
begin
EnterCriticalSection(FLock);
try
WriteLn(FTextFile, ErrorText);
finally
LeaveCriticalSection(FLock);
end;
end;
end.
to test the class I created a form with a timer set to 100 milliseconds:
procedure TForm1.Timer1Timer(Sender: TObject);
var
I : integer;
aErrorLog : TErrorLog;
begin
aErrorLog := nil;
for I := 0 to 1000 do begin
try
aErrorLog := TErrorLog.Create(FormatDateTime('ddmmyyyy', Now) + '.txt');
aErrorLog.Write('new line');
finally
if Assigned(aErrorLog) then FreeAndNil(aErrorLog);
end;
end;
end;
the logs are written, but occasionally raise I/O Error 32 exception on CloseFile(FTextFile) (probably because in use in another thread)
where am I doing wrong?
UPDATE:
after reading all the comments and the answers I have totally changed approach. I share my solution.
ThreadUtilities.pas
(* Implemented for Delphi3000.com Articles, 11/01/2004
Chris Baldwin
Director & Chief Architect
Alive Technology Limited
http://www.alivetechnology.com
*)
unit ThreadUtilities;
interface
uses Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
end;
implementation
{ TThreadQueue }
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue <> 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
(* Pop will return false if the queue is completed *)
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, ULONG_PTR(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
while FThreads.Count < MaxThreads do
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count > 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
end.
ThreadFileLog.pas
(* From: http://delphi.cjcsoft.net/viewthread.php?tid=45763 *)
unit ThreadFileLog;
interface
uses Windows, ThreadUtilities, System.Classes;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText : String;
FileName : String;
end;
TThreadFileLog = class(TObject)
private
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create();
destructor Destroy; override;
procedure Log(const FileName, LogText: string);
end;
implementation
uses
System.SysUtils;
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create();
begin
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
begin
Request := Data;
try
LogToFile(Request^.FileName, Request^.LogText);
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const FileName, LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
Request^.FileName := FileName;
FThreadPool.Add(Request);
end;
end.
Basic form example
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
Vcl.StdCtrls, ThreadFileLog;
type
TForm1 = class(TForm)
BtnStart: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
private
FThreadFileLog : TThreadFileLog;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.BtnStartClick(Sender: TObject);
var
I : integer;
aNow : TDateTime;
begin
aNow := Now;
for I := 0 to 500 do
FThreadFileLog.Log(
FormatDateTime('ddmmyyyyhhnn', aNow) + '.txt',
FormatDateTime('dd-mm-yyyy hh:nn:ss.zzz', aNow) + ': I: ' + I.ToString
);
ShowMessage('logs are performed!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FThreadFileLog := TThreadFileLog.Create();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FThreadFileLog.Free;
ReportMemoryLeaksOnShutdown := true;
end;
end.
Output log:
30-11-2014 14.01.13.252: I: 0
30-11-2014 14.01.13.252: I: 1
30-11-2014 14.01.13.252: I: 2
30-11-2014 14.01.13.252: I: 3
30-11-2014 14.01.13.252: I: 4
30-11-2014 14.01.13.252: I: 5
30-11-2014 14.01.13.252: I: 6
30-11-2014 14.01.13.252: I: 7
30-11-2014 14.01.13.252: I: 8
30-11-2014 14.01.13.252: I: 9
...
30-11-2014 14.01.13.252: I: 500
Instead of checking TTextRec(FTextFile).Mode <> fmTextOpenWrite you should check whether your file is closed or not, and if it is not closed then you close it.
Try replacing the mentioned check with this code:
if TTextRec(FTextFile).Mode <> fmClosed then
CloseFile(FTextFile);
Edited:
This has nothing to do with antivirus locking the file. This is just a simple mistake in the destructor.
File is already opened in open write mode, original code is closing the file only when it is not in open write mode - so it is never closing the file.
Hope this explains where the mistake has happened.
As for the overall design of the logger's class. This was not the question, questions was simple, and I've provided a simple and working solution.
I think that if Simone would want us to teach him how to design logger class then he would ask for it.
If you want an error log class, where multiple threads can write to a log file, it is correct to protect the writing method with a critical section.
Now, since you will only instantiate one of those error logging objects in your application, there is no need to protect the destructor method with a critical section.
The location of your error log file should reside in the application data folder.
The I/O error 32 is: The process cannot access the file because it is being used by another process.
The reason for this sharing violation could be in your application or an external application.
Writing inside the application directory could trigger some antivirus protection for example. Or your application is holding the file open in several places with different file modes.
Your test is flawed in multiple ways:
Instantiate the error log class once at application start, and destroy it when the application closes.
Write to your error log from different threads, not from multiple iterations within a timer event.
A timer event should only execute a program sequence for a short duration.
A try / finally sequence is structured like this:
anObject := TObject.Create;
try
// Do something with anObject
finally
anObject.Free;
end;
I am using Delphi 2007 & Indy 10; I am a bit of a Delphi noob so apologies if I have missed something obvious...
Background: I have a simple server app which simply sends the word "PING" when you connect to its port. It will also respond if it receives the word "PONG". This is working fine, I have manually tested this using netcat/wireshark.
I am trying to code my client to connect to the port and automatically respond to the word PING whenever it receives it. I have created a simple form with a button to manually connect.
The client connects, but it does not respond to the word PING.
I think the problem lies with:
TLog.AddMsg(FConn.IOHandler.ReadLn);
My debug log reports only as far as "DEBUG: TReadingThread.Execute - FConn.Connected".
My client code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCustomTransparentProxy, IdSocks, IdBaseComponent,
IdComponent, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack,
IdTCPConnection, IdTCPClient, IdSync;
type
TReadingThread = class(TThread)
protected
FConn: TIdTCPConnection;
procedure Execute; override;
public
constructor Create(AConn: TIdTCPConnection); reintroduce;
end;
TLog = class(TIdSync)
protected
FMsg: String;
procedure DoSynchronize; override;
public
constructor Create(const AMsg: String);
class procedure AddMsg(const AMsg: String);
end;
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
IdIOHandlerStack1: TIdIOHandlerStack;
client: TIdTCPClient;
IdSocksInfo1: TIdSocksInfo;
procedure Button1Click(Sender: TObject);
procedure clientConnected(Sender: TObject);
procedure clientDisconnected(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
rt: TReadingThread = nil;
implementation
{$R *.dfm}
constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Create'); // Debug
FConn := AConn;
inherited Create(False);
end;
procedure TReadingThread.Execute;
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Execute'); // Debug
while not Terminated and FConn.Connected do
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Execute - FConn.Connected'); // Debug
TLog.AddMsg(FConn.IOHandler.ReadLn);
end;
end;
constructor TLog.Create(const AMsg: String);
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.Create'); // Debug
FMsg := AMsg;
inherited Create;
end;
procedure TLog.DoSynchronize;
var
cmd : string;
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.DoSynchronize'); // Debug
cmd := copy(FMsg, 1, 1);
if cmd='PING' then begin
Form1.client.Socket.WriteLn('PONG');
end
end;
class procedure TLog.AddMsg(const AMsg: String);
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.AddMsg'); // Debug
with Create(AMsg) do try
Synchronize;
finally
Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Host : String;
Port : Integer;
begin
Host := '127.0.0.1';
Port := StrToInt('1234');
client.Host := Host;
client.Port := Port;
with client do
begin
try
Connect;
except
on E: Exception do
Memo1.Lines.Add('Error: ' + E.Message);
end;
end;
end;
procedure TForm1.clientConnected(Sender: TObject);
begin
Form1.Memo1.Lines.Add('DEBUG: TForm1.clientConnected'); // Debug
rt := TReadingThread.Create(client);
end;
procedure TForm1.clientDisconnected(Sender: TObject);
begin
Form1.Memo1.Lines.Add('DEBUG: TForm1.clientDisconnected'); // Debug
if rt <> nil then
begin
rt.Terminate;
rt.WaitFor;
FreeAndNil(rt);
end;
end;
end.
Any help/advice would be appreciated.
Thanks
The reading thread is directly accessing Form1.Memo1, which is not thread safe and can cause deadlocks, crashes, corrupted memory, etc. So it is possible that the reading thread is not even reaching the ReadLn() call at all. You MUST synchronize ALL access to UI controls to the main thread, no matter how trivial the access actually is. Just don't risk it.
Also, you are doing your thread's ping/pong logic inside of TLog itself, where it does not belong. Not to mention that you are truncating the cmd to only its first character before checking its value, so it will NEVER detect a PING command. You need to move the logic back into the thread, where it really belongs, and remove the truncation.
Try this:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCustomTransparentProxy, IdSocks, IdBaseComponent,
IdComponent, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack,
IdTCPConnection, IdTCPClient, IdSync;
type
TReadingThread = class(TThread)
protected
FConn: TIdTCPConnection;
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(AConn: TIdTCPConnection); reintroduce;
end;
TLog = class(TIdSync)
protected
FMsg: String;
procedure DoSynchronize; override;
public
constructor Create(const AMsg: String);
class procedure AddMsg(const AMsg: String);
end;
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
IdIOHandlerStack1: TIdIOHandlerStack;
client: TIdTCPClient;
IdSocksInfo1: TIdSocksInfo;
procedure Button1Click(Sender: TObject);
procedure clientConnected(Sender: TObject);
procedure clientDisconnected(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
rt: TReadingThread = nil;
implementation
{$R *.dfm}
constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
TLog.AddMsg('DEBUG: TReadingThread.Create');
FConn := AConn;
inherited Create(False);
end;
procedure TReadingThread.Execute;
var
cmd: string;
begin
TLog.AddMsg('DEBUG: TReadingThread.Execute');
while not Terminated do
begin
cmd := FConn.IOHandler.ReadLn;
TLog.AddMsg('DEBUG: TReadingThread.Execute. Cmd: ' + cmd);
if cmd = 'PING' then begin
FConn.IOHandler.WriteLn('PONG');
end
end;
end;
procedure TReadingThread.DoTerminate;
begin
TLog.AddMsg('DEBUG: TReadingThread.DoTerminate');
inherited;
end;
constructor TLog.Create(const AMsg: String);
begin
inherited Create;
FMsg := AMsg;
end;
procedure TLog.DoSynchronize;
begin
Form1.Memo1.Lines.Add(FMsg);
end;
class procedure TLog.AddMsg(const AMsg: String);
begin
with Create(AMsg) do
try
Synchronize;
finally
Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Host : String;
Port : Integer;
begin
Host := '127.0.0.1';
Port := StrToInt('1234');
client.Host := Host;
client.Port := Port;
try
client.Connect;
except
on E: Exception do
TLog.AddMsg('Error: ' + E.Message);
end;
end;
end;
procedure TForm1.clientConnected(Sender: TObject);
begin
TLog.AddMsg('DEBUG: TForm1.clientConnected');
rt := TReadingThread.Create(client);
end;
procedure TForm1.clientDisconnected(Sender: TObject);
begin
TLog.AddMsg('DEBUG: TForm1.clientDisconnected');
if rt <> nil then
begin
rt.Terminate;
rt.WaitFor;
FreeAndNil(rt);
end;
end;
end.
If that still does not work, then make sure the server is actually delimiting the PING string with a CRLF sequence, or at least a LF character (which is the minimum that ReadLn() looks for by default).
I'm trying to put an indy TIdHttp in a thread,
I have tried this :
type
TSendThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
public
http : TIdHTTP;
URL : String;
Method : String;
property ReturnValue;
end;
procedure TSendThread.Execute;
begin
form1.Memo1.lines.Add(http.Get(URL));
ReturnValue := 1;
end;
And in the main :
procedure TForm1.Button1Click(Sender: TObject);
var t : TSendThread;
begin
t := TSendThread.Create(true);
t.URL := 'http://www.url.com/';
t.http := http;
t.Start;
showmessage(IntToStr(t.ReturnValue));
end;
My problem here is that the next instruction gets executed(showmessage) without waiting the thread to be done, i tried to use the "WaitFor" but it freezes the application.
Is there any other workaround?
Thank you.
Use the TThread.OnTerminate event to know when the thread has finished:
type
TSendThread = class(TThread)
private
http : TIdHTTP;
Line: string;
procedure AddLine;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
URL : String;
Method : String;
property ReturnValue;
end;
constructor TSendThread.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
http := TIdHTTP.Create;
end;
destructor TSendThread.Destroy;
begin
http.Free;
inherited;
end;
procedure TSendThread.Execute;
begin
Line := http.Get(URL);
Synchronize(AddLine);
ReturnValue := 1;
end;
procedure TSendThread.AddLine;
begin
Form1.Memo1.Lines.Add(Line);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
t : TSendThread;
begin
t := TSendThread.Create;
t.URL := 'http://www.url.com/';
t.OnTerminate := ThreadTerminated;
t.Start;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
ShowMessage(IntToStr(TSendThread(Sender).ReturnValue));
end;
If you want to use a loop to wait for the thread to finish, without blocking the UI, then you can do it like this:
constructor TSendThread.Create;
begin
inherited Create(True);
//FreeOnTerminate := True; // <-- remove this
http := TIdHTTP.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
t : TSendThread;
h : THandle;
begin
t := TSendThread.Create;
try
t.URL := 'http://www.url.com/';
t.Start;
h := t.Handle;
repeat
case MsgWaitForMultipleObjects(1, h, 0, INFINITE, QS_ALLINPUT) of
WAIT_OBJECT_0: Break;
WAIT_OBJECT_0+1: Application.ProcessMessages;
WAIT_FAILED: RaiseLastOSError;
else
Break;
end;
until False;
ShowMessage(IntToStr(t.ReturnValue));
finally
t.Free;
end;
end;
Download the source code with compiled executable (221 KB (226,925 bytes)): http://www.eyeclaxton.com/download/delphi/skeleton.zip
Why doesn't the Destroy destructor get called if I close the application (click the X button) before the thread has terminated? FastMM4 reports a memory leak with FPauseEvent event.
How should i destroy thread? If someone closes the application before the thread finishes.
unit SkeletonThread;
interface
uses
Windows, Classes, SysUtils, SyncObjs;
type
TOnInitialize = procedure(Sender: TObject; const AMaxValue: Integer) of object;
TOnBegin = procedure(Sender: TObject) of object;
TOnProgress = procedure(Sender: TObject; const APosition: Integer) of object;
TOnPause = procedure(Sender: TObject; const APaused: Boolean) of object;
TOnFinish = procedure(Sender: TObject) of object;
TOnFinalize = procedure(Sender: TObject) of object;
TMasterThread = class(TThread)
private
{ Private declarations }
FPaused: Boolean;
FPosition: Integer;
FMaxValue: Integer;
FOnBegin: TOnBegin;
FOnProgress: TOnProgress;
FOnFinish: TOnFinish;
FOnInitialize: TOnInitialize;
FOnFinalize: TOnFinalize;
FPauseEvent: TEvent;
FOnPause: TOnPause;
procedure BeginEvent();
procedure ProgressEvent();
procedure FinishEvent();
procedure InitializeEvent();
procedure FinalizeEvent();
procedure PauseEvent();
procedure CheckForPause();
protected
{ Protected declarations }
procedure DoInitializeEvent(const AMaxValue: Integer); virtual;
procedure DoBeginEvent(); virtual;
procedure DoProgress(const APosition: Integer); virtual;
procedure DoPauseEvent(const APaused: Boolean); virtual;
procedure DoFinishEvent(); virtual;
procedure DoFinalizeEvent(); virtual;
public
{ Public declarations }
constructor Create(const CreateSuspended: Boolean; const theValue: Integer);
destructor Destroy(); override;
procedure Pause();
procedure Unpause();
published
{ Published declarations }
property IsPaused: Boolean read FPaused write FPaused default False;
property OnInitialize: TOnInitialize read FOnInitialize write FOnInitialize default nil;
property OnBegin: TOnBegin read FOnBegin write FOnBegin default nil;
property OnProgress: TOnProgress read FOnProgress write FOnProgress default nil;
property OnPause: TOnPause read FOnPause write FOnPause default nil;
property OnFinish: TOnFinish read FOnFinish write FOnFinish default nil;
property OnFinalize: TOnFinalize read FOnFinalize write FOnFinalize default nil;
end;
TSkeletonThread = class(TMasterThread)
private
{ Private declarations }
procedure DoExecute(const theValue: Integer);
protected
{ Protected declarations }
procedure Execute(); override;
public
{ Public declarations }
published
{ Published declarations }
end;
implementation
{ TMasterThread }
constructor TMasterThread.Create(const CreateSuspended: Boolean; const theValue: Integer);
begin
inherited Create(CreateSuspended);
Self.FreeOnTerminate := True;
Self.FPosition := 0;
Self.FMaxValue := theValue;
Self.FPaused := False;
Self.FPauseEvent := TEvent.Create(nil, True, True, '');
end;
destructor TMasterThread.Destroy();
begin
FreeAndNil(FPauseEvent);
if (Pointer(FPauseEvent) <> nil) then Pointer(FPauseEvent) := nil;
inherited Destroy();
end;
procedure TMasterThread.DoBeginEvent();
begin
if Assigned(Self.FOnBegin) then Self.FOnBegin(Self);
end;
procedure TMasterThread.BeginEvent();
begin
Self.DoBeginEvent();
end;
procedure TMasterThread.DoProgress(const APosition: Integer);
begin
if Assigned(Self.FOnProgress) then Self.FOnProgress(Self, APosition);
end;
procedure TMasterThread.ProgressEvent();
begin
Self.DoProgress(Self.FPosition);
end;
procedure TMasterThread.DoFinishEvent();
begin
if Assigned(Self.FOnFinish) then Self.FOnFinish(Self);
end;
procedure TMasterThread.FinishEvent();
begin
Self.DoFinishEvent();
end;
procedure TMasterThread.DoInitializeEvent(const AMaxValue: Integer);
begin
if Assigned(Self.FOnInitialize) then Self.FOnInitialize(Self, AMaxValue);
end;
procedure TMasterThread.InitializeEvent();
begin
Self.DoInitializeEvent(Self.FMaxValue);
end;
procedure TMasterThread.DoFinalizeEvent();
begin
if Assigned(Self.FOnFinalize) then Self.FOnFinalize(Self);
end;
procedure TMasterThread.FinalizeEvent;
begin
Self.DoFinalizeEvent();
end;
procedure TMasterThread.DoPauseEvent(const APaused: Boolean);
begin
if Assigned(Self.FOnPause) then Self.FOnPause(Self, APaused);
end;
procedure TMasterThread.PauseEvent();
begin
Self.DoPauseEvent(Self.FPaused);
end;
procedure TMasterThread.Pause();
begin
Self.FPauseEvent.ResetEvent();
Self.FPaused := True;
Self.Synchronize(Self.PauseEvent);
end;
procedure TMasterThread.Unpause();
begin
Self.FPaused := False;
Self.Synchronize(Self.PauseEvent);
Self.FPauseEvent.SetEvent();
end;
procedure TMasterThread.CheckForPause();
begin
if (not (Self.Terminated)) then Windows.Sleep(1);
Self.FPauseEvent.WaitFor(INFINITE);
end;
{ TSkeletonThread }
procedure TSkeletonThread.DoExecute(const theValue: Integer);
var
X: Integer;
begin
Self.Synchronize(InitializeEvent);
try
Self.Synchronize(BeginEvent);
try
for X := 0 to (theValue - 1) do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := Self.FPosition + 1;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
for X := Self.FPosition downto 1 do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := X;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
finally
Self.Synchronize(FinishEvent);
end;
finally
Self.Synchronize(FinalizeEvent);
end;
end;
procedure TSkeletonThread.Execute();
begin
Self.DoExecute(Self.FMaxValue);
end;
end.
You have to terminate the thread yourself (tell it to stop). One way is to use the Terminate procedure of the thread, but you have to check for this in the thread Execute method. Something like this:
procedure Execute;
begin
inherited;
while not Terminated do
begin
// do your job
end;
end;
procedure TForm1.StopThread;
begin
MyThread.Terminate;
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Or you can use signalization build into windows so you do not have to loop.
procedure Execute;
begin
inherited;
while not Terminated do
begin
WaitStatus := WaitForSingleObject(FTermEvent, Max(0, SleepInterval));
// check what was the cause for signalization
if WaitStatus <> WAIT_TIMEOUT then
Terminate;
end;
end;
procedure TForm1.StopThread;
begin
// Terminate the thread
SetEvent(FTermEvent);
// close the handle
CloseHandle(FTermEvent);
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Signalization can be very neat way of signaling for termination because you can use WaitForMultipleObjects and release the wait in different conditions. I used WaitForSingleObject to not complicate things to much.
Also be sure to set "FreeOnTerminate := True" in thread constructor. Oh and the hard termination at the end is optional of course. It can be dangerous. You know best yourself if you will use it or not. You can also wait for a longer period or infinite if you are sure the thread will stop eventually.