I'm using IdTCPClient and IdThreadComponent to get some information for a barcode reader. This code, with some changes is working in Delphi 11 and Indy 10 but not in Delphi 2007 and Indy 9:
procedure TPkgSendF1.IdThreadComponent1Run(Sender: TIdCustomThreadComponent);
var
s: String;
begin
s := IdTCPClient1.ReadLn('&', 20000, 1500);
TThread.Queue(nil, procedure // <== Expected # but received PROCEDURE
begin
ProcessRead(s);
end);
end;
// [DCC Error] PkgSendF1.pas(239): E2029 Expression expected but 'PROCEDURE' found
procedure TPkgSendF1.ProcessRead(AValue: string);
begin
Memo1.Text := AValue;
end;
If I don't use the TThread.Queue I miss some readings.
I'll appreciate any help.
Francisco Alvarado
Anonymous methods did not exist yet in Delphi 2007, they were introduced in Delphi 2010. As such, TThread.Queue() in D2007 only had 1 version that accepted a TThreadMethod:
type
TThreadMethod = procedure of object;
Which means you need to wrap the call to ProcessRead() inside a helper object that has a procedure with no parameters, eg:
type
TQueueHelper = class
public
Caller: TPkgSendF1;
Value: String;
procedure DoProcessing;
end;
procedure TQueueHelper.DoProcessing;
begin
try
Caller.ProcessRead(Value);
finally
Free;
end;
end;
procedure TPkgSendF1.IdThreadComponent1Run(Sender: TIdCustomThreadComponent);
var
s: string;
begin
s := IdTCPClient1.ReadLn('&', 20000, 1500);
with TQueueHelper.Create do
begin
Caller := Self;
Value := s;
TThread.Queue(nil, DoProcessing);
end;
end;
FYI, Indy (both 9 and 10) has an asynchronous TIdNotify class in the IdSync unit, which you can use instead of using TThread.Queue() directly, eg:
uses
IdSync;
type
TMyNotify = class(TIdNotify)
public
Caller: TPkgSendF1;
Value: String;
procedure DoNotify; override;
end;
procedure TMyNotify.DoNotify;
begin
Caller.ProcessRead(Value);
end;
procedure TPkgSendF1.IdThreadComponent1Run(Sender: TIdCustomThreadComponent);
var
s: string;
begin
s := IdTCPClient1.ReadLn('&', 20000, 1500);
with TMyNotify.Create do
begin
Caller := Self;
Value := s;
Notify;
end;
end;
Related
I'm trying to implement an IDE Wizard with ToolsApi and using the GExperts FAQ (http://www.gexperts.org/examples/GXModuleCreator.pas) as reference.
Although the bpl compiles, the unit doesn't shows up on the IDE.
I'm Using Delphi 10.3.2 Rio.
unit ModuleCreator;
interface
uses
SysUtils, Windows, Dialogs, ToolsAPI;
type
TJIdeWizardSourceFile = class(TInterfacedObject, IOTAFile)
private
FSource: string;
public
function GetSource: string;
function GetAge: TDateTime;
constructor Create(const Source: string);
end;
TJIdeWizardModuleCreator = class(TInterfacedObject, IOTACreator, IOTAModuleCreator)
public
// IOTACreator
function GetCreatorType: string;
function GetExisting: Boolean;
function GetFileSystem: string;
function GetOwner: IOTAModule;
function GetUnnamed: Boolean;
// IOTAModuleCreator
function GetAncestorName: string;
function GetImplFileName: string;
function GetIntfFileName: string;
function GetFormName: string;
function GetMainForm: Boolean;
function GetShowForm: Boolean;
function GetShowSource: Boolean;
function NewFormFile(const FormIdent, AncestorIdent: string): IOTAFile;
function NewImplSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile;
function NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile;
procedure FormCreated(const FormEditor: IOTAFormEditor);
end;
implementation
{ TJIdeWizardModuleCreator }
procedure TJIdeWizardModuleCreator.FormCreated(const FormEditor: IOTAFormEditor);
begin
//
end;
function TJIdeWizardModuleCreator.GetAncestorName: string;
begin
Result := 'Form';
end;
function TJIdeWizardModuleCreator.GetCreatorType: string;
begin
Result := sUnit;
end;
function TJIdeWizardModuleCreator.GetExisting: Boolean;
begin
Result := False;
end;
function TJIdeWizardModuleCreator.GetFileSystem: string;
begin
Result := '';
end;
function TJIdeWizardModuleCreator.GetFormName: string;
begin
Result := '';
end;
function TJIdeWizardModuleCreator.GetImplFileName: string;
begin
Result := '';
end;
function TJIdeWizardModuleCreator.GetIntfFileName: string;
begin
Result := '';
end;
function TJIdeWizardModuleCreator.GetMainForm: Boolean;
begin
Result := False;
end;
function TJIdeWizardModuleCreator.GetOwner: IOTAModule;
var
ModuleServices: IOTAModuleServices;
Module: IOTAModule;
NewModule: IOTAModule;
begin
// You may prefer to return the project group's ActiveProject instead
Result := nil;
ModuleServices := (BorlandIDEServices as IOTAModuleServices);
Module := ModuleServices.CurrentModule;
if Module <> nil then
begin
if Module.QueryInterface(IOTAProject, NewModule) = S_OK then
Result := NewModule
else if Module.OwnerModuleCount > 0 then
begin
NewModule := Module.OwnerModules[0];
if NewModule <> nil then
if NewModule.QueryInterface(IOTAProject, Result) <> S_OK then
Result := nil;
end;
end;
end;
function TJIdeWizardModuleCreator.GetShowForm: Boolean;
begin
Result := True;
end;
function TJIdeWizardModuleCreator.GetShowSource: Boolean;
begin
Result := True;
end;
function TJIdeWizardModuleCreator.GetUnnamed: Boolean;
begin
Result := True;
end;
function TJIdeWizardModuleCreator.NewFormFile(const FormIdent, AncestorIdent: string): IOTAFile;
begin
Result := nil;
end;
function TJIdeWizardModuleCreator.NewImplSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile;
begin
// or Result := nil; for the default unit
Result := nil;
end;
function TJIdeWizardModuleCreator.NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile;
begin
Result := nil;
end;
{ TJIdeWizardSourceFile }
constructor TJIdeWizardSourceFile.Create(const Source: string);
begin
FSource := Source;
end;
function TJIdeWizardSourceFile.GetAge: TDateTime;
begin
Result := -1;
end;
function TJIdeWizardSourceFile.GetSource: string;
begin
result := FSource;
end;
end.
Here is an example of how I´m calling the method "NewImplSource" from IOTAModuleCreator
procedure TfrmMapearObjetoRelacional.btnSimpleORMDaoClick(Sender: TObject);
var
_Mod: TJIdeWizardModuleCreator;
_Str: string;
begin
_Mod := TJIdeWizardModuleCreator.Create;
try
_Str := _Mod.NewImplSource('unit1','','');
ShowMessage(_Str);
finally
FreeAndNil(_Mod);
end;
end;
The answer for the question is YES it does.
The problem was that one should not call "NewImplSource" directly.
In order for it to work, it should be called based on the result from "GetCreatorType" inside the "IOTAModuleCreator" Constructor.
for instance:
procedure TJModuleCreatorWizard.Execute;
begin
(BorlandIDEServices as IOTAModuleServices).CreateModule(TJModuleCreator.Create);
end;
Where "TJModuleCreator" implements IOTAModuleCreator interface.
Martyn, thak you very much for your assistance, in fact I was able to figure it out by simplifying the scenario as you suggested on your answer.
If you don't have any luck debugging this in a second instance of the IDE like I suggested
in a project, I think you should consider changing your code do follow the way I go about
implementing something like this.
I implement the OTA interface of interest on a small form. Although the form is, in principle,
unnecessary, it is very useful to give a visual sign that the thing's working and there is actually
quite a lot of debugging you can do without having to resort to the second-IDE-instance business. You can build quite a lot of debugging facilities into the form by placing a small TMemo on it
and using it as a logging facility to record what it does. And, of course, the form can have
a MainMenu or whatever to invoke various of the OTA interface's methods to check that they do
what they are supposed to do.
The form shouldn't be autocreated. Instead, create and call .Show on it in the `Initialization'
section of the form's unit and Free it in its Finalization section.
Once you've compiled the .Dpk containing the form, install it in the IDE using Install Packages.
I always write OTA stuff in a form like this and very rarely get into any major problems that need
the second-IDE-instance to investigate and resolve.
Good luck!
I don't understand why this very simple code failed? I'm on Delphi Tokyo release 2.
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Generics.Collections;
procedure Main;
var
aQueue: TQueue<TBytes>;
aBytes: TBytes;
begin
aQueue := TQueue<TBytes>.create;
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 4 as expected
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 0
end;
begin
Main;
Readln;
end.
Is this a bug?
NOTE: The code works correctly on XE4, but fails also on Berlin.
This is indeed a bug. The code works correctly in XE7, but not XE8. In XE8 the output is 0 for both attempts.
Certainly the XE8 generic collections were very buggy and subsequent releases fixed many of the defects. Clearly not all have been fixed.
In XE8 Embarcadero attempted to address the issue of generic bloat caused by weaknesses in their compile/link model. Unfortunately, instead of tackling the problem at the root, they chose instead to address the issue in the library code for generic collections. Doing so they completely broke many of the generic collection classes, proving that their unit testing was weak. And of course, by addressing the problem this way they failed to address the issue of generic bloat for classes other than those in the generic collections. All in all, a sorry story that is seemingly still not over.
loki has just submitted a bug report: RSP-20400.
Note that this bug report is incorrect because (at least according to Stefan Glienke) the bug has been fixed in Tokyo 10.2.3. So upgrading to 10.2.3 should be the simplest way to resolve the problem.
Perhaps this bug report is more appropriate: RSP-17728.
Writing a generic queue isn't even difficult. Here's one that is known to work:
type
TQueue<T> = class
private
FItems: TArray<T>;
FCount: Integer;
FFront: Integer;
private
function Extract(Index: Integer): T; inline;
function GetBack: Integer; inline;
property Back: Integer read GetBack;
property Front: Integer read FFront;
procedure Grow;
procedure RetreatFront; inline;
public
property Count: Integer read FCount;
procedure Clear;
procedure Enqueue(const Value: T);
function Dequeue: T;
function Peek: T;
public
type
TEnumerator = record
private
FCollection: TQueue<T>;
FCount: Integer;
FCapacity: Integer;
FIndex: Integer;
FStartIndex: Integer;
public
class function New(Collection: TQueue<T>): TEnumerator; static;
function GetCurrent: T;
property Current: T read GetCurrent;
function MoveNext: Boolean;
end;
public
function GetEnumerator: TEnumerator;
end;
function GrownCapacity(OldCapacity: Integer): Integer;
var
Delta: Integer;
begin
if OldCapacity>64 then begin
Delta := OldCapacity div 4
end else if OldCapacity>8 then begin
Delta := 16
end else begin
Delta := 4;
end;
Result := OldCapacity + Delta;
end;
{ TQueue<T> }
function TQueue<T>.Extract(Index: Integer): T;
begin
Result := FItems[Index];
if IsManagedType(T) then begin
Finalize(FItems[Index]);
end;
end;
function TQueue<T>.GetBack: Integer;
begin
Result := Front + Count - 1;
if Result>high(FItems) then begin
dec(Result, Length(FItems));
end;
end;
procedure TQueue<T>.Grow;
var
Index: Integer;
Value: T;
Capacity: Integer;
NewItems: TArray<T>;
begin
Capacity := Length(FItems);
if Count=Capacity then begin
SetLength(NewItems, GrownCapacity(Capacity));
Index := 0;
for Value in Self do begin
NewItems[Index] := Value;
inc(Index);
end;
FItems := NewItems;
FFront := 0;
end;
end;
procedure TQueue<T>.RetreatFront;
begin
inc(FFront);
if FFront=Length(FItems) then begin
FFront := 0;
end;
end;
procedure TQueue<T>.Clear;
begin
FItems := nil;
FCount := 0;
end;
procedure TQueue<T>.Enqueue(const Value: T);
begin
Grow;
inc(FCount);
FItems[Back] := Value;
end;
function TQueue<T>.Dequeue: T;
var
Index: Integer;
begin
Assert(Count>0);
Result := Extract(Front);
RetreatFront;
dec(FCount);
end;
function TQueue<T>.Peek: T;
begin
Assert(Count>0);
Result := FItems[Front];
end;
function TQueue<T>.GetEnumerator: TEnumerator;
begin
Result := TEnumerator.New(Self);
end;
{ TQueue<T>.TEnumerator }
class function TQueue<T>.TEnumerator.New(Collection: TQueue<T>): TEnumerator;
begin
Result.FCollection := Collection;
Result.FCount := Collection.Count;
Result.FCapacity := Length(Collection.FItems);
Result.FIndex := -1;
Result.FStartIndex := Collection.Front;
end;
function TQueue<T>.TEnumerator.GetCurrent: T;
var
ActualIndex: Integer;
begin
ActualIndex := (FStartIndex + FIndex) mod FCapacity;
Result := FCollection.FItems[ActualIndex];
end;
function TQueue<T>.TEnumerator.MoveNext: Boolean;
begin
inc(FIndex);
Result := FIndex<FCount;
end;
To add to David's answer, the bug is in the Enqueue method. The top branch should be handling all reference counted managed types.
if IsManagedType(T) then
if (SizeOf(T) = SizeOf(Pointer)) and (GetTypeKind(T) <> tkRecord) then
FQueueHelper.InternalEnqueueMRef(Value, GetTypeKind(T))
else
FQueueHelper.InternalEnqueueManaged(Value)
else
But here we see that dynamic arrays are conspicuously missing in InternalEnqueueMref, which falls through without doing anything:
procedure TQueueHelper.InternalEnqueueMRef(const Value; Kind: TTypeKind);
begin
case Kind of
TTypeKind.tkUString: InternalEnqueueString(Value);
TTypeKind.tkInterface: InternalEnqueueInterface(Value);
{$IF not Defined(NEXTGEN)}
TTypeKind.tkLString: InternalEnqueueAnsiString(Value);
TTypeKind.tkWString: InternalEnqueueWideString(Value);
{$ENDIF}
{$IF Defined(AUTOREFCOUNT)}
TTypeKind.tkClass: InternalEnqueueObject(Value);
{$ENDIF}
end;
end;
It's so egregious, in fact, that the compiler actually produces no code for Enqueue when compiled (other than preamble) since the futility of the exercise can be determined from the types at compile time.
Project1.dpr.15: aQueue.Enqueue(aBytes);
0043E19E 8B45F8 mov eax,[ebp-$08]
0043E1A1 8945F4 mov [ebp-$0c],eax
0043E1A4 8B45FC mov eax,[ebp-$04]
0043E1A7 83C008 add eax,$08
0043E1AA 8945F0 mov [ebp-$10],eax
Project1.dpr.16: aBytes := aQueue.Dequeue;
0043E1AD 8D45EC lea eax,[ebp-$14]
This bug, therefore, would be expected to affect TQueue<T> for T being any type of dynamic array.
I have 2 years old project which I am rebooting back to life. I have debug window which shows different information, and one part of them is that it serializes various google protobuf objects and shows them.
Here is how typical protobuf class looks like:
// Generated by the protocol buffer compiler. DO NOT EDIT!
// Source: message.proto
unit Poker.Protobufs.Objects.PingParams;
interface
uses
System.SysUtils,
{$IFNDEF FPC} System.Generics.Collections {$ELSE} Contnrs {$ENDIF},
pbOutput, Poker.Protobufs.Objects.Base, Poker.Protobufs.Reader, Poker.Types;
type
TPB_PingParams = class(TProtobufBaseObject)
private
const
kUptimeFieldNumber = 1;
var
FUptime: UInt32;
FHasBits: UINT32;
procedure set_has_Uptime;
procedure clear_has_Uptime;
procedure SetUptime(const AValue: UInt32);
public
constructor Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE); overload;
destructor Destroy; override;
procedure LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer); override;
procedure MergeFrom(const AFrom: TPB_PingParams);
procedure Clear;
function IsInitialized: Boolean; override;
// required uint32 Uptime = 1;
function has_Uptime: Boolean;
procedure clear_Uptime;
property Uptime: UInt32 read FUptime write SetUptime;
end;
TPB_PingParamsList = class(TObjectList<TPB_PingParams>)
procedure Assign(const APB_PingParamsList: TList<TPB_PingParams>);
end;
implementation
uses
pbPublic;
constructor TPB_PingParams.Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE);
begin
inherited Create(ALightweight);
MergeFrom(AFrom);
end;
destructor TPB_PingParams.Destroy;
begin
inherited;
end;
procedure TPB_PingParams.LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer);
var
tag, field_number, wire_type, endpos: Integer;
begin
endpos := AProtobufReader.getPos + ASize;
while (AProtobufReader.getPos < endpos) and
(AProtobufReader.GetNext(tag, wire_type, field_number)) do
case field_number of
kUptimeFieldNumber: begin
Assert(wire_type = WIRETYPE_VARINT);
FUptime := AProtobufReader.readUInt32;
set_has_Uptime;
end;
else
AProtobufReader.skipField(tag);
end;
end;
procedure TPB_PingParams.MergeFrom(const AFrom: TPB_PingParams);
begin
if AFrom.has_Uptime then
SetUptime(AFrom.Uptime);
end;
function TPB_PingParams.IsInitialized: Boolean;
begin
if (FHasBits and $1) <> $1 then
Exit(FALSE);
Exit(TRUE);
end;
procedure TPB_PingParams.clear_Uptime;
begin
FUptime := 0;
clear_has_Uptime;
end;
function TPB_PingParams.has_Uptime: Boolean;
begin
result := (FHasBits and 1) > 0;
end;
procedure TPB_PingParams.set_has_Uptime;
begin
FHasBits := FHasBits or 1;
end;
procedure TPB_PingParams.clear_has_Uptime;
begin
FHasBits := FHasBits and not 1;
end;
procedure TPB_PingParams.SetUptime(const AValue: UInt32);
begin
if not Lightweight then
Assert(not has_Uptime);
FUptime := AValue;
if not Lightweight then
ProtobufOutput.writeUInt32(kUptimeFieldNumber, AValue);
set_has_Uptime;
end;
procedure TPB_PingParams.Clear;
begin
if FHasBits = 0 then
Exit;
clear_Uptime;
end;
procedure TPB_PingParamsList.Assign(const APB_PingParamsList: TList<TPB_PingParams>);
var
pbobj: TPB_PingParams;
begin
Clear;
for pbobj in APB_PingParamsList do
Add(TPB_PingParams.Create(pbobj, TRUE));
end;
end.
And my serialization function:
function SerializeObject(const AObject: TObject): String;
var
t: TRttiType;
p: TRttiProperty;
properties: TArray<TRttiProperty>;
method: TRttiMethod;
begin
result := '';
if not Assigned(AObject) then
Exit;
t := TRttiContext.Create.GetType(AObject.ClassType);
properties := t.GetProperties;
for p in properties do
begin
method := t.GetMethod(Format('has_%s', [p.Name]));
if (Assigned(method)) and
(method.Invoke(AObject, []).AsBoolean) then
result := result + Format('%s: %s; ', [p.Name, ValueToStr(p, p.GetValue(AObject))]);
end;
end;
It is specifically designed to serialize fields that begin with has_ in protobuf objects. Now, I didn't change anything in the code over last 2 years, and this was working before. But now it doesn't. Line properties = t.GetProperties returns empty array for my protobuf classes.
My guess is that I had some globally defined compiler directive which allowed me to serialize public methods in the class. But I cannot figure out which one.
If I put {$M+} in front of my protobuf classes, and move methods to published, it works (kinda). But this worked before just like it is shown in the sources, without any {$M+} directives or similar. So I'm curious what I miss.
Compiler is same as before, XE2.
I was trying to compile this delphi code:
delphi UDP server
unit UDP.Server;
interface
uses
IdUDPServer,
IdSocketHandle,
System.SysUtils;
type
TResponseToMessage = reference to function(const AMsg : string):string;
TUDPServer = class
strict private const
DEFAULT_UDP_PORT = 49152;
strict private
FidUDPServer : TIdUDPServer;
FResponseToMessage: TResponseToMessage;
FEndOfProtocol: string;
class var FInstance : TUDPServer;
constructor Create();
destructor Free();
procedure UDPRead (AThread: TIdUDPListenerThread; AData: TArray<System.Byte>; ABinding: TIdSocketHandle);
private
class procedure ReleaseInstance();
public
procedure SetReponseToMessage(AFunction : TResponseToMessage);
procedure SetUDPPort(const APort : word);
procedure StartListen();
property EndOfProtocol : string read FEndOfProtocol write FEndOfProtocol;
class function GetInstance() : TUDPServer;
end;
implementation
{ TUdpServer }
constructor TUDPServer.Create;
begin
Self.FidUDPServer := TIdUDPServer.Create(nil);
Self.FidUDPServer.OnUDPRead := Self.UDPRead;
Self.FidUDPServer.DefaultPort := Self.DEFAULT_UDP_PORT;
end;
destructor TUDPServer.Free;
begin
Self.FidUDPServer.Free;
end;
class function TUDPServer.GetInstance: TUDPServer;
begin
if not Assigned(Self.FInstance) then
Self.FInstance := TUDPServer.Create();
Result := Self.FInstance;
end;
class procedure TUDPServer.ReleaseInstance;
begin
if Assigned(Self.FInstance) then
Self.FInstance.Free;
end;
procedure TUDPServer.SetReponseToMessage(AFunction: TResponseToMessage);
begin
Self.FResponseToMessage := AFunction;
end;
procedure TUDPServer.SetUDPPort(const APort: word);
begin
Self.FidUDPServer.Active := false;
Self.FidUDPServer.DefaultPort := APort;
Self.FidUDPServer.Active := true;
end;
procedure TUDPServer.StartListen;
begin
if not Self.FidUDPServer.Active then
Self.FidUDPServer.Active := true;
end;
procedure TUDPServer.UDPRead(AThread: TIdUDPListenerThread;
AData: TArray<System.Byte>; ABinding: TIdSocketHandle);
var
sResponse: string;
begin
sResponse := EmptyStr;
if Assigned(Self.FResponseToMessage) then
sResponse := Self.FResponseToMessage(StringOf(AData));
if sResponse <> EmptyStr then
ABinding.SendTo(ABinding.PeerIP,ABinding.PeerPort,sResponse);
ABinding.SendTo(ABinding.PeerIP,ABinding.PeerPort,Self.FEndOfProtocol);
end;
initialization
finalization
TUDPServer.ReleaseInstance();
end.
I get the error on Self.FidUDPServer.OnUDPRead := Self.UDPRead; line
E2009 Incompatible types: 'Parameter lists differ'
I can't figure out what is causing this error.
Replace TArray<System.Byte> with TIdBytes as that is what Indy is expecting you to use here. The code you have is likely from an older version of Indy.
I have a legacy delphi 2007 application that sends email alarms via TurboPower Internet Professional 1.15 (tpipro). I have recently revisited the application to find that the email send no longer is working because of the TLS/SSL requirements from most email servers. Now my question is where to go from here.
I Have Delphi XE2, but really have no desire to take the time to update my application to work on this ide. It has many library dependencies and so forth.
Is there a 3rd party email client that is up to date that will work on Delphi 2007? Or perhaps a .dll that could be used?
You can use the Indy library which is included in delphi, these components support TLS and SSL (take a look to the TIdSmtp Component), you can find the last version of Indy Here.
Just to give you some more options
You could also try IPWorks its not free thou, you can find it Here or you might wanna look at ICS (Internet Component Suite) Which is freeware and you can find that Here
Indy is the obvious choice as it comes installed with Delphi XE2
Just did this yesterday (you can replace my own classes with VCL classes to get it to work):
unit SmtpClientUnt;
interface
uses
Classes, IdSslOpenSsl, IdSmtp, CsiBaseObjectsUnt, DevExceptionsUnt;
type
ESmtpClient = class(EDevException);
TSmtpClient = class sealed(TCsiBaseObject)
private
FHostName: string;
FIdSmtpClient: TIdSmtp;
FIoHandler: TIdSslIoHandlerSocketOpenSsl;
FUseTls: Boolean;
protected
procedure CheckIsOpen(const pEventAction: string);
function GetHostName: string; virtual;
function GetIsOpen: Boolean; virtual;
function GetObjectName: string; override;
public
const LC_SMTP_CLIENT = 'SMTP Client';
constructor Create(const pHostName: string; pUseTls: Boolean = False);
destructor Destroy; override;
procedure Close;
procedure Open(const pUserName: string = ''; const pPassword: string = '');
procedure Reconnect;
procedure SendMessage(pToAddresses: TStrings; const pFromAddress: string;
const pSubject: string; const pBody: string;
pAttachmentFiles: TStrings = nil);
property HostName: string read GetHostName;
property IsOpen: Boolean read GetIsOpen;
end;
implementation
uses
SysUtils, IdAttachmentFile, IdEmailAddress, IdExplicitTlsClientServerBase, IdMessage,
CsiExceptionsUnt, CsiGlobalsUnt, CsiSingletonManagerUnt, CsiStringsUnt;
{ TSmtpClient }
procedure TSmtpClient.CheckIsOpen(const pEventAction: string);
begin
if not IsOpen then
raise ESmtpClient.Create('Cannot ' + pEventAction +
' while the SMTP client is not open', slError, 1,
ObjectName);
end;
procedure TSmtpClient.Close;
begin
if IsOpen then begin
CsiGlobals.AddLogMsg('Closing SMTP client', LC_SMTP_CLIENT, llVerbose, ObjectName);
FIdSmtpClient.Disconnect;
end;
end;
constructor TSmtpClient.Create(const pHostName: string; pUseTls: Boolean);
begin
FHostName := pHostName;
FUseTls := pUseTls;
inherited Create;
if FHostName = '' then
raise ESmtpClient.Create('Cannot create SMTP client - empty host name', slError, 2,
ObjectName);
FIdSmtpClient := TIdSmtp.Create(nil);
FIdSmtpClient.Host := pHostName;
if FUseTls then begin
FIoHandler := TIdSslIoHandlerSocketOpenSsl.Create(nil);
FIdSmtpClient.IoHandler := FIoHandler;
FIdSmtpClient.UseTls := utUseRequireTls;
end;
end;
destructor TSmtpClient.Destroy;
begin
Close;
if FUseTls and Assigned(FIdSmtpClient) then begin
FIdSmtpClient.IoHandler := nil;
FreeAndNil(FIoHandler);
end;
FreeAndNil(FIdSmtpClient);
inherited;
end;
function TSmtpClient.GetHostName: string;
begin
if Assigned(FIdSmtpClient) then
Result := FIdSmtpClient.Host
else
Result := FHostName;
end;
function TSmtpClient.GetIsOpen: Boolean;
begin
Result := Assigned(FIdSmtpClient) and FIdSmtpClient.Connected;
end;
function TSmtpClient.GetObjectName: string;
var
lHostName: string;
begin
Result := inherited GetObjectName;
lHostName := HostName;
if lHostName <> '' then
Result := Result + ' ' + lHostName;
end;
procedure TSmtpClient.Open(const pUserName: string; const pPassword: string);
begin
if not IsOpen then begin
with FIdSmtpClient do begin
Username := pUserName;
Password := pPassword;
Connect;
end;
CsiGlobals.AddLogMsg('SMTP client opened', LC_SMTP_CLIENT, llVerbose, ObjectName);
end;
end;
procedure TSmtpClient.Reconnect;
begin
Close;
Open;
end;
procedure TSmtpClient.SendMessage(pToAddresses: TStrings; const pFromAddress: string;
const pSubject: string; const pBody: string;
pAttachmentFiles: TStrings);
var
lMessage: TIdMessage;
lAddress: string;
lName: string;
lIndex: Integer;
lAddressItem: TIdEMailAddressItem;
lAttachmentFile: TIdAttachmentFile;
lFileName: string;
begin
CheckIsOpen('send message');
lMessage := TIdMessage.Create(nil);
try
with lMessage do begin
CsiSplitFirstStr(pFromAddress, ',', lAddress, lName);
From.Address := lAddress;
From.Name := lName;
Subject := pSubject;
Body.Text := pBody;
end;
for lIndex := 0 to pToAddresses.Count - 1 do begin
lAddressItem := lMessage.Recipients.Add;
CsiSplitFirstStr(pToAddresses.Strings[lIndex], ',', lAddress, lName);
lAddressItem.Address := lAddress;
lAddressItem.Name := lName;
end;
if Assigned(pAttachmentFiles) then
for lIndex := 0 to pAttachmentFiles.Count - 1 do begin
lAttachmentFile := TIdAttachmentFile.Create(lMessage.MessageParts);
lFileName := pAttachmentFiles.Strings[lIndex];
lAttachmentFile.StoredPathName := lFileName;
lAttachmentFile.FileName := lFileName;
end;
FIdSmtpClient.Send(lMessage);
finally
lMessage.Free;
end;
end;
procedure InitialiseUnit;
begin
CsiAllCapWords.AddString('SMTP');
end;
initialization
CsiSingletonManager.RegisterHook(InitialiseUnit, nil);
end.
Here are the Demo codes:
http://www.indyproject.org/sockets/demos/index.en.aspx
IdPOP3 / IdSMTP / IdMessage