I want to make a function on the Idtcpclient that repeats the ReadLn command.
But how can i do this? I don't want to use a timer because a timer is slow.
I allready searched on google but i don't understand it..
The client can be placed in a separate thread, and use a loop to repeat the ReadLn until it succeeds. The time out can be given as an argument to ReadLn so that the next try will happen after the timeout interval. Make sure to handle connection loss, for example by reconnecting in a loop.
I create a unit to my program, I hope to help you:
unit uSerialAuthentication;
interface
uses System.SysUtils, IdTCPClient, IdThreadComponent, FMX.Dialogs;
type
TSerialAuthentication = class (TObject)
IdTCPClient: TIdTCPClient;
procedure IdThreadComponentRun(Sender: TIdThreadComponent);
public
constructor Create (Host : string; Port: Word);
destructor Destroy; override;
procedure OnConnect(Sender: TObject);
end;
var
idThreadComponent : TIdThreadComponent; // Thread
Access : Boolean;
implementation
{ SerialAuthentication }
procedure TSerialAuthentication.OnConnect(Sender: TObject);
begin
ShowMessage('Connected');
IdThreadComponent.Active := True;
end;
constructor TSerialAuthentication.Create(Host : string; Port: Word);
begin
IdTCPClient := TIdTCPClient.Create();
IdTCPClient.Host := Host;
IdTCPClient.Port := Port;
IdTCPClient.OnConnected := OnConnect;
idThreadComponent := TIdThreadComponent.Create();
idThreadComponent.OnRun := IdThreadComponentRun;
Access := False;
end;
destructor TSerialAuthentication.Destroy;
begin
IdTCPClient.Disconnect;
if idThreadComponent.active then
begin
idThreadComponent.active := False;
end;
FreeAndNil(IdThreadComponent);
if Assigned(IdTCPClient) then
FreeAndNil (IdTCPClient);
inherited;
end;
procedure TSerialAuthentication.IdThreadComponentRun(Sender: TIdThreadComponent);
var
recv : String;
begin
recv := IdTCPClient.IOHandler.ReadLn(); // READ
if length(recv)>0 then
if recv = 'Ready' then
Access := True
else
Access := False;
end;
end.
Related
I am successfully using Delphi's TRESTRequest.ExecuteAsync to query a REST API and parse the results without blocking the main thread.
This is for a mobile app with devices moving in and out of coverage, so I want to check that the server is reachable immediately prior to making the call. I tried using TRESTClient's timeout, but it takes 30 seconds to fire, even when Airplane mode is turned on.
I have a very quick and reliable function CheckServerIsAvailable, but it is synchronous. To avoid blocking the main thread, I call CheckServerIsAvailable via Task.Run, and using TThread.Synchronize to update my UI when it's done. This seems to work reliably.
However, I want the application to continue from that point and either show a message that the server is unavailable OR continue into making the call to the server. I don't want to put all the additional error checking and JSON parsing etc code inside the Thread.Synchronize procedure declaration as it will quickly become unreadable.
Thread.Synchronize docs says the anonymous procedure is called on the main thread, so I tried to continue the execution by calling another procedure from there as follows:
procedure TForm1.Button1Click(Sender: TObject);
begin
StartWithPart1;
end;
procedure TForm1.StartWithPart1;
begin
Label1.Text := 'Looking...';
AniIndicator1.Enabled := true;
TTask.Run(
procedure
begin
Connected := CheckServerIsReachable; // this is a blocking call
TThread.Synchronize(nil,
procedure
begin
Label1.Text := ifthen(Connected, 'Connected', 'Not connected');
AniIndicator1.Enabled := false;
ShowMessage('leaving part 1');
ContinueWithPart2;
end);
end);
end;
procedure TForm1.ContinueWithPart2;
begin
ShowMessage('entering part 2');
// this is where I want to make the REST call, handle errors and parse results etc
end;
This seems to work correctly, with the TAniIndicator animating and labels updating correctly, but when I run the code above, the message "entering part 2" appears before "leaving part 1", which makes me think that my (limited) understanding of TThread.Synchronize is either incorrect or incomplete or both.
Is this approach reasonable? Why does the second message appear before the first if TThread.Synchronize is executing on the main thread? Is there a better model to be using to achieve what I'm trying to do?
UPDATE:
Thanks for the awesome help, everyone - I wasn't aware that dialogs on mobile are async and order of presentation is independent of order of creation.
For completeness, I tried an alternative approach based on subclassing TThread which seems to work equally well, and I feel results in more readable code as follows:
unit ServerCheck;
interface
uses
System.SysUtils, System.Types, System.UITypes,
System.Classes, System.Variants, System.Threading,
IdTCPClient;
type
TServerCheck = class(TThread)
Connected: Boolean;
TCPClient: TIdTCPClient;
private
function IsServerReachable: Boolean;
public
constructor Create(host: string; port: Integer; timeout: Integer;
callback: TNotifyEvent);
destructor Destroy; override;
procedure Execute; override;
end;
implementation
const
BUSY = 1;
NOT_BUSY = 0;
constructor TServerCheck.Create(host: string; port: Integer; timeout: Integer;
callback: TNotifyEvent);
begin
inherited Create(true);
FreeOnTerminate := true;
OnTerminate := callback;
TCPClient := TIdTCPClient.Create;
TCPClient.host := host;
TCPClient.port := port;
TCPClient.ReadTimeout := timeout;
TCPClient.ConnectTimeout := timeout;
end;
destructor TServerCheck.Destroy;
begin
TCPClient.Free;
inherited;
end;
function TServerCheck.IsServerReachable: Boolean;
begin
try
if TCPClient.Tag = NOT_BUSY then
begin
TCPClient.Tag := BUSY;
TCPClient.Connect;
TCPClient.Disconnect;
TCPClient.Tag := NOT_BUSY;
result := true;
end
else
begin
result := false;
end
except
begin
TCPClient.Tag := NOT_BUSY;
result := false;
end;
end;
end;
procedure TServerCheck.Execute;
begin
Connected := IsServerReachable;
end;
end.
and then from another form:
procedure TForm1.Button1Click(Sender: TObject);
var
netCheck: TServerCheck;
begin
Label1.Text := 'Checking';
AniIndicator1.Visible := true;
AniIndicator1.Enabled := true;
netCheck := TServerCheck.Create('www.stackoverflow.com', 443, 6000, Callback);
netCheck.Start;
end;
procedure TForm1.Callback(Sender: TObject);
begin
AniIndicator1.Enabled := false;
AniIndicator1.Visible := false;
Label1.Text := IfThen(TServerCheck(Sender).Connected, 'Connected', 'Not connected');
end;
I have a simple TidTCPServer Working on a console and accepting Data. My problem is when the client Send Stream but having a very high of speed exchange data, The server freeze after 70 lines and the CPU load of the server go to 70%; I don't know how can i resolve without adding a sleep between every send . below an example of Client and Server . Can you help me to resolve this (Server Side) thanks .
program Srv;
{$I Synopse.inc}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, Generics.Collections, IdTCPServer, IdCustomTCPServer, IdContext, IdGlobal, Db, mORMot, mORMotSQLite3, IdSync, functions, SynCommons, SynSQLite3Static;
type
{ TMyApplication }
TMyApplication = class(TCustomApplication)
var IdTCPServer: TIdTCPServer;
protected
procedure DoRun; override;
procedure ServerOnConnect(AContext: TIdContext);
procedure ServerOnExecute(AContext: TIdContext);
function ReceiveStream(AContext: TIdContext;Size:integer; var AStream: TStream);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
end;
type
TLog = class(TIdNotify)
protected
FMsg: string;
procedure DoNotify; override;
public
class procedure LogMsg(const AMsg: string);
end;
{ TMyApplication }
procedure TLog.DoNotify;
var i:integer;
begin
writeln(FMsg);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
with TLog.Create do
try
FMsg := AMsg;
Notify;
except
Free;
raise;
end;
end;
function TMyApplication.ReceiveStream(AContext: TIdContext; var AStream: TStream)
: Boolean; overload;
var
LSize: LongInt;
begin
Result := True;
try
LSize := AContext.Connection.IOHandler.ReadLongInt();
AContext.Connection.IOHandler.ReadStream(AStream,LSize, False)
AStream.Seek(0,soFromBeginning);
except
Result := False;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
var AStream:TMemoryStream;
begin
if (Acontext.Connection.IOHandler.InputBufferIsEmpty) then
begin
TLog.LogMsg('--: '+random(100000).ToString); //After executing Client this line is displayed 70 time and CPU load is from 40 % to 70%
AStream:=TMemoryStream.Create;
try
ReceiveStream(AContext,TStream(AStream));
// .. here we use AStream to execute some stuff
finally
Astream.free;
end;
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect');
end;
procedure TMyApplication.DoRun;
begin
IdTCPServer := tIdTCPServer.Create;
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 0;
IdTCPServer.TerminateWaitTime := 5000;
with IdTCPServer.Bindings.Add
do begin
IP := '0.0.0.0';
Port := 80;
IPVersion:=Id_IPv4;
end;
IdTCPServer.OnConnect := ServerOnConnect;
IdTCPServer.OnDisconnect := ServerOnDiconnect;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
while true do
begin
Classes.CheckSynchronize() ;
sleep(10);
end;
readln;
Terminate;
end;
constructor TMyApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException := True;
end;
destructor TMyApplication.Destroy;
begin
IdTCPServer.Free;
inherited Destroy;
end;
var
Application: TMyApplication;
begin
Application := TMyApplication.Create(nil);
Application.Title := 'My Application';
Application.Run;
Application.Free;
end.
Client
function TForm1.SendStream(AClient: TIdTCPClient; AStream: TStream): Boolean; overload;
var
StreamSize: LongInt;
begin
try
Result := True;
try
AStream.Seek(0,soFromBeginning);
StreamSize := (AStream.Size);
AClient.IOHandler.Write(LongInt(StreamSize));
AClient.IOHandler.WriteBufferOpen;
AClient.IOHandler.Write(AStream, 0, False);
AClient.IOHandler.WriteBufferFlush;
finally
AClient.IOHandler.WriteBufferClose;
end;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Packet:TPacket;
AStream:TMemoryStream;
begin
for i:=0 to 1000 do
begin
Application.ProcessMessages;
With Packet do
begin
MX := random(10000);
MY := random(10000);
end;
AStream:=TMemoryStream.Create;
try
AStream.Write(Packet,SizeOf(TPacket));
SendStream(IdTCPClientCmd,TStream(AStream));
finally
AStream.Free;
end;
end;
end;
On the server side, your InputBufferIsEmpty() check is backwards. If the client is sending a lot of data, InputBufferIsEmpty() is likely to become False eventually, which will cause your server code to enter a tight unyielding loop that doesn't actually read anything. Just get rid of the check entirely and let ReceiveStream() block until there is a packet available to read.
Also, why are you setting the server's ListenQueue to 15, but the MaxConnections to 0? MaxConnections=0 will force the server to immediately close every client connection that is accepted, so the OnExecute event will never get a chance to be called.
On the client side, there is no need to destroy and recreate the TMemoryStream on each loop iteration, you should reuse that object.
But more importantly, you are not using write buffering correctly, so either fix that or get rid of it. I would do the latter, as you are sending lots of small packets, so just let TCP's default coalescing handle the buffering for you.
And TIdIOHandler.Write(TStream)/TIdIOHandler.ReadStream() can exchange the stream size for you, you don't need to do that manually.
Try this instead:
Server
program Srv;
{$I Synopse.inc}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, Generics.Collections, IdTCPServer, IdCustomTCPServer, IdContext, IdGlobal, Db, mORMot, mORMotSQLite3, IdSync, functions, SynCommons, SynSQLite3Static;
type
{ TMyApplication }
TMyApplication = class(TCustomApplication)
var
IdTCPServer: TIdTCPServer;
protected
procedure DoRun; override;
procedure ServerOnConnect(AContext: TIdContext);
procedure ServerOnExecute(AContext: TIdContext);
function ReceiveStream(AContext: TIdContext; Size: Integer; var AStream: TStream);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
end;
type
TLog = class(TIdNotify)
protected
FMsg: string;
procedure DoNotify; override;
public
class procedure LogMsg(const AMsg: string);
end;
{ TMyApplication }
procedure TLog.DoNotify;
begin
WriteLn(FMsg);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
with TLog.Create do
try
FMsg := AMsg;
Notify;
except
Free;
raise;
end;
end;
function TMyApplication.ReceiveStream(AContext: TIdContext; AStream: TStream): Boolean; overload;
begin
try
AContext.Connection.IOHandler.ReadStream(AStream, -1, False);
AStream.Position := 0;
Result := True;
except
Result := False;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
var
AStream: TMemoryStream;
begin
AStream := TMemoryStream.Create;
try
if not ReceiveStream(AContext, AStream) then
begin
AContext.Connection.Disconnect;
Exit;
end;
TLog.LogMsg('--: '+random(100000).ToString); //After executing Client this line is displayed 70 time and CPU load is from 40 % to 70%
// .. here we use AStream to execute some stuff
finally
AStream.Free;
end;
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect');
AContext.Connection.IOHandler.LargeStream := False;
end;
procedure TMyApplication.DoRun;
begin
IdTCPServer := TIdTCPServer.Create;
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 1;
IdTCPServer.TerminateWaitTime := 5000;
with IdTCPServer.Bindings.Add do
begin
IP := '0.0.0.0';
Port := 80;
IPVersion := Id_IPv4;
end;
IdTCPServer.OnConnect := ServerOnConnect;
IdTCPServer.OnDisconnect := ServerOnDiconnect;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
while True do
begin
Classes.CheckSynchronize();
Sleep(10);
end;
ReadLn;
Terminate;
end;
constructor TMyApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException := True;
end;
destructor TMyApplication.Destroy;
begin
IdTCPServer.Free;
inherited Destroy;
end;
var
Application: TMyApplication;
begin
Application := TMyApplication.Create(nil);
Application.Title := 'My Application';
Application.Run;
Application.Free;
end.
Client
function TForm1.SendStream(AClient: TIdTCPClient; AStream: TStream): Boolean; overload;
begin
try
AClient.IOHandler.LargeStream := False; // <-- or, set this 1 time after TIdTCPClient.Connect() exits...
AClient.IOHandler.Write(AStream, 0, True);
Result := True;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Packet: TPacket;
AStream: TMemoryStream;
i: Integer;
begin
AStream := TMemoryStream.Create;
try
AStream.Size := SizeOf(TPacket);
for i := 0 to 1000 do
begin
Application.ProcessMessages;
with Packet do
begin
MX := random(10000);
MY := random(10000);
end;
AStream.Position := 0;
AStream.Write(Packet, SizeOf(TPacket));
SendStream(IdTCPClientCmd, AStream);
end;
finally
AStream.Free;
end;
end;
I have a Lazarus console app where I have a simple TIdTCPServer. To be a thread safe app, I added TLog.LogMsg() (which uses TIdNotify).
The problem is, when I call this function from the main thread, the message appears on the console, but when it is called from the OnExecute or OnConnect event of TIdTCPServer, the message is not displayed.
Can you help me with this problem?
program Srv;
{$I Synopse.inc}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, Generics.Collections, IdTCPServer, IdCustomTCPServer, IdContext, IdGlobal, Db, mORMot, mORMotSQLite3, IdSync, functions, SynCommons, SynSQLite3Static;
type
{ TMyApplication }
TMyApplication = class(TCustomApplication)
var IdTCPServer: TIdTCPServer;
protected
procedure DoRun; override;
procedure ServerOnConnect(AContext: TIdContext);
procedure ServerOnExecute(AContext: TIdContext);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
end;
type
TLog = class(TIdNotify)
protected
FMsg: string;
procedure DoNotify; override;
public
class procedure LogMsg(const AMsg: string);
end;
{ TMyApplication }
procedure TLog.DoNotify;
var i:integer;
begin
writeln(FMsg);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
with TLog.Create do
try
FMsg := AMsg;
Notify;
except
Free;
raise;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
begin
TLog.LogMsg('test OnExecute'); // the message is not displayed
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect'); // the message is not displayed
end;
procedure TMyApplication.DoRun;
begin
TLog.LogMsg('test main 1'); //the message is displayed
IdTCPServer := TIdTCPServer.Create;
try
//Server.Name := 'Server';
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 0;
IdTCPServer.TerminateWaitTime := 5000;
IdTCPServer.Bindings.Add.IP := '0.0.0.0';
IdTCPServer.Bindings.Add.Port := 80;
IdTCPServer.Bindings.Add.IPVersion:=Id_IPv4;
IdTCPServer.OnConnect := ServerOnConnect;
// IdTCPServer.OnDisconnect := ServerOnDiconnect;
//Server.OnException := IdTCPServer1Exception;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
TLog.LogMsg('test main 2'); //the message is displayed
finally
// IdTCPServerCmd.Free;
end;
readln;
// stop program loop
Terminate;
end;
constructor TMyApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException := True;
end;
destructor TMyApplication.Destroy;
begin
IdTCPServer.Free;
inherited Destroy;
end;
var
Application: TMyApplication;
begin
Application := TMyApplication.Create(nil);
Application.Title := 'My Application';
Application.Run;
Application.Free;
end.
Your main thread does not have a message loop to process TThread.Synchronize()/TThread.Queue() requests. It is blocked on Readln(). Since you are in a console app and not a GUI app, you need to manually call Classes.CheckSynchronize() periodically in the main thread.
On a side note, you are calling IdTCPServer.Bindings.Add() too many times. In your example, you need to call it only 1 time, creating 1 binding that has the 3 property values assigned to it. But instead, you are calling it 3 times, creating 3 separate bindings with 3 separate property settings. It should look more like this instead:
with IdTCPServer.Bindings.Add do
begin
IP := '0.0.0.0';
Port := 80;
IPVersion := Id_IPv4;
end;
Which can be simplified as 0.0.0.0 and Id_IPv4 are already the default values, so they can be omitted from your code. And TIdTCPServer has a DefaultPort property you can use instead. The TIdTCPServer.Active property setter will create its own default bindings if there are none defined explicitly.
I started playing with Indy TCPServer and TCPClient few weeks ago, and now, after lots of research and help from SOF experts (specially Mr. Lebeau), I can securely manage client connections and send a string message to a specific client. Here is a piece of the code:
type
TClient = class(TObject)
private
FHost: string;
public
FQMsg: TIdThreadSafeStringList; // Message Queue
constructor Create(const Host: string);
destructor Destroy; override;
end;
procedure TfrmMain.TCPServerExecute(AContext: TIdContext);
var
Client: TClient;
LQueue: TStringList;
WQueue: TStringList;
begin
with AContext.Connection.IOHandler Do
begin
DefStringEncoding := TEncoding.UTF8;
LQueue := nil;
Client := TClient(AContext.Data);
try
WQueue := Client.FQMsg.Lock;
try
if (WQueue.Count > 0) then
begin
LQueue := TStringList.Create;
LQueue.Assign(WQueue);
WQueue.Clear;
end;
finally
Client.FQMsg.Unlock;
end;
if (LQueue <> nil) then
Write(LQueue);
finally
LQueue.Free;
end;
end;
end;
Now it's time to go a step further, and try to receive an answer from the client. But suddenly I realize that I can't use the TCPServer's OnExecute event to send the message and receive answer at "same time"?? I am probably wrong, but this code isn't working, and I have no idea why...
procedure TfrmMain.TCPServerExecute(AContext: TIdContext);
var
RStr: string;
Client: TClient;
LQueue: TStringList;
WQueue: TStringList;
begin
with AContext.Connection.IOHandler Do
begin
DefStringEncoding := TEncoding.UTF8;
// Send Cmd
LQueue := nil;
Client := TClient(AContext.Data);
try
WQueue := Client.FQMsg.Lock;
try
if (WQueue.Count > 0) then
begin
LQueue := TStringList.Create;
LQueue.Assign(WQueue);
WQueue.Clear;
end;
finally
Client.FQMsg.Unlock;
end;
if (LQueue <> nil) then
Write(LQueue);
finally
LQueue.Free;
end;
// Receive Data
RStr := Trim(ReadLn);
if (RStr <> '') then
begin
SyncLog(RStr);
end;
end;
end;
When I add this last part (ReadLn) together, the first part of the code do not work, I cannot send the message to client anymore :(
Please, anyone knows what I missing?
Thank you!
First, use TIdTextEncoding.UTF8 instead of TEncoding.UTF8 (or IndyTextEncoding_UTF8 if you upgrade to Indy 10.6+), and move the assignment of DefStringEncoding to the OnConnect event. You only need to assign it once, not on every read/write.
Second, ReadLn() is a blocking method. It does exit until a line of actually read, or a timeout/error occurs. So, to do what you are attempting, you have to check for the existence of inbound data before you actually read it, so that you can timeout and Exit and let OnExecute loop back to check the queue again.
Try something like this:
type
TClient = class(TObject)
private
FHost: string;
FQMsg: TIdThreadSafeStringList; // Message Queue
public
constructor Create(const Host: string);
destructor Destroy; override;
property QMsg: TIdThreadSafeStringList read FQMsg;
end;
procedure TfrmMain.TCPServerConnect(AContext: TIdContext);
var
Client: TClient;
begin
AContext.Connection.IOHandler.DefStringEncoding := TIdTextEncoding.UTF8;
...
Client := TClient.Create;
...
AContext.Data := Client;
...
end;
procedure TfrmMain.TCPServerExecute(AContext: TIdContext);
var
RStr: string;
Client: TClient;
LQueue: TStringList;
WQueue: TStringList;
begin
Client := TClient(AContext.Data);
// Send Cmd
LQueue := nil;
try
WQueue := Client.QMsg.Lock;
try
if (WQueue.Count > 0) then
begin
LQueue := TStringList.Create;
LQueue.Assign(WQueue);
WQueue.Clear;
end;
finally
Client.QMsg.Unlock;
end;
if (LQueue <> nil) then
AContext.Connection.IOHandler.Write(LQueue);
finally
LQueue.Free;
end;
// Receive Data
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
if not AContext.Connection.IOHandler.CheckForDataOnSource(100) then Exit;
AContext.Connection.IOHandler.CheckForDisconnect;
end;
RStr := Trim(AContext.Connection.IOHandler.ReadLn);
if (RStr <> '') then
begin
SyncLog(RStr);
end;
end;
I want to send email in other unit with different thread with indy10.0.52
I have source code
unit ThreadEmail;
interface
uses Classes, SysUtils, IdGlobal, IdMessage, IdIOHandler, IdIOHandlerSocket,
IdSSLOpenSSL, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdMessageClient, IdSMTP, IdExplicitTLSClientServerBase, IdSMTPBase,
IdIOHandlerStack, IdSSL, ExtCtrls;
type
TThreadEmail = class(TThread)
private
run : boolean;
counter : Integer;
target : Integer;
IdSMTP: TIdSMTP;
IdSSLIOHandlerSocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
Messages : Array [0..10] of TIdMessage;
procedure checkRun();
protected
procedure Execute; override;
public
constructor Create(timerInS:Integer;host:string;port:integer;username,password:String;readTimeout : integer = 0);reintroduce;
function expressSend(recipients,subject,body:string;from:String='';replayTo:String='') :boolean;
function makeEmail(recipients,subject,body:string;from:String='';replayTo:String=''): boolean;
procedure SendAllEmail();
end;
implementation
constructor TThreadEmail.Create(timerInS:Integer;host:string;port:integer;username,password:String;readTimeout : integer = 0);
var b: byte;
begin
inherited Create(False);
Priority:= tpNormal;
FreeOnTerminate:= True;
IdSMTP := TIdSMTP.Create;
IdSSLIOHandlerSocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create();
for b:=low(Messages) to high(messages) do Messages[b] := nil;
IdSMTP.IOHandler := IdSSLIOHandlerSocketOpenSSL;
IdSMTP.UseTLS := utUseImplicitTLS;
IdSMTP.Host := host;
IdSMTP.Port := port;
IdSMTP.Username := username;
IdSMTP.Password := password;
IdSSLIOHandlerSocketOpenSSL.DefaultPort := 0;
IdSSLIOHandlerSocketOpenSSL.Destination := host+':'+inttostr(port);
IdSSLIOHandlerSocketOpenSSL.Host := host;
IdSSLIOHandlerSocketOpenSSL.MaxLineAction := maException;
IdSSLIOHandlerSocketOpenSSL.Port := port;
IdSSLIOHandlerSocketOpenSSL.ReadTimeout := readTimeout;
IdSSLIOHandlerSocketOpenSSL.SSLOptions.Method := sslvSSLv3;
IdSSLIOHandlerSocketOpenSSL.SSLOptions.Mode := sslmClient;
run:=true;
//target := timerInS*10;
end;
function TThreadEmail.expressSend(recipients,subject,body:string;from:String='';replayTo:String='') : boolean;
var IdMessage: TIdMessage;
begin
Result := false;
IdMessage := TIdMessage.Create();
IdMessage.Recipients.EMailAddresses := recipients;
IdMessage.Subject := subject;
IdMessage.Body.Text := body;
if from <> '' then IdMessage.From.Address := from;
if replayTo <> '' then IdMessage.ReplyTo.EMailAddresses := from;
try
IdSMTP.Connect();
IdSMTP.Send(IdMessage);
Result := true;
finally
IdSMTP.Disconnect();
end;
end;
function TThreadEmail.makeEmail(recipients,subject,body:string;from:String='';replayTo:String='') : boolean;
var b: byte;
begin
Result := false;
for b:=low(Messages) to high(messages) do
if Messages[b] = nil then
begin
Result := true;
Messages[b]:= TIdMessage.Create();
Messages[b].Recipients.EMailAddresses := recipients;
Messages[b].Subject := subject;
Messages[b].Body.Text := body;
if from <> '' then Messages[b].From.Address := from;
if replayTo <> '' then Messages[b].ReplyTo.EMailAddresses := from;
end;
if not(result) then
begin
SendAllEmail();
makeEmail(recipients,subject,body,from,replayTo);
end;
end;
procedure TThreadEmail.SendAllEmail();
var b: byte;
begin
try
IdSMTP.Connect();
for b:=low(Messages) to high(messages) do
if run and (Messages[b] <> nil) then
begin
try
IdSMTP.Send(Messages[b]);
finally
Messages[b].Free;
Messages[b] := nil;
end
end;
finally
IdSMTP.Disconnect();
end;
end;
procedure TThreadEmail.checkRun();
begin
Dec(counter);
if counter <= 0 then SendAllEmail();
end;
procedure TThreadEmail.Execute;
var b: byte;
begin
while run do
begin
sleep(100);
checkRun();
end;
IdSMTP.Free;
IdSSLIOHandlerSocketOpenSSL.Free;
for b:=low(Messages) to high(messages) do
if Messages[b] <> nil then Messages[b].Free;
end;
end.
and in mainfrom that i create
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadEmail;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var ThreadEmail : TThreadEmail;
begin
ThreadEmail := ThreadEmail.Create(10,'smtp.gmail.com',465,'xxx.gmail.com','xxx',2000);
ThreadEmail.expressSend('xxx#yahoo.com','TES','TES');
end;
When button1 clicked, it always "create access violation error", Why it happend? can anyone help me? as a info, i sucesed send a email before, but i want to make a singgle unit that can run alone.
thanks
ThreadEmail := ThreadEmail.Create(10,'s....
this should be :
ThreadEmail := TThreadEmail.Create(10,'s....
Not sure if that's just a typo? It will definitely cause an AV if not.
In any case, ThreadEmail.expressSend will not run in your TThread's thread the way you are calling it. When you run a TThread the code in its Execute method will run in a separate thread. Any of the public member methods, however, can be called on an instance just like public methods of any class and they are executed on the thread that calls them.
To get this to work you need to have the Execute method performing the calls to send the email message. The UI thread needs to trigger action in the Execute method and not perform the action itself; this can be done by any number of means (having Execute synchronize with WaitForSingleObject, via message passing, etc).
The rest of your code looks rather broken. Your Execute code is not really going to work as it is - this loop :
while run do
begin
sleep(100);
checkRun();
end;
will never terminate as it seems you don't set run to false anywhere. Furthermore, counter does not seem to get set anywhere (nor do I really understand its purpose) so this will just SendAllEmail() every 100ms or so.
The makeEmail function will never terminate (stack overflow) since it calls itself recursively with the original arguments and the logic guarantees re-entry on each pass. It also looks like it will send whatever message eleven times on each recursion (since all 11 elements of Messages will be nil after initialization and after each call to SendAllEmail().
Even if you fix this - if you are calling makeEmail externally (ie: from the UI or another thread) then this will likely end up with all sorts of cross-thread errors since both Execute and the calling thread will be trying to call SendAllEmail at the same time. This code will need some work.