{------------------------------------------------------------------------------}
{ Created by : Lanthan Astat } }
{------------------------------------------------------------------------------}
{ Module Details }
{------------------------------------------------------------------------------}
{
Project : SMTPEngine
Module Authors : Lanthan Astat (Astat)
}
{------------------------------------------------------------------------------}
{ Module Description }
{------------------------------------------------------------------------------}
{
Standalone native SMTP Engine.
}
{------------------------------------------------------------------------------}
{ Module History }
{------------------------------------------------------------------------------}
{
- Initial version 1.0 25.06.2003
- version 1.1 13.08.2003 Attachment Bug Fixed
- version 1.2 24.09.2003 socket close
- Usage:
...
uses
Email in 'Email.pas';
var
smtp:TSMTPEngine;
SendOk:boolean;
begin
smtp:=TSMTPEngine.Create(
'10.73.22.23', // 'ESSXLC001.esa.local'; Server
'max.mustermann@esa.com', // Recip,
'this is the mail message text', // Body,
'MAIL_SERVICE', // From,
'max.mustermann@esa.com', // Cc,
'Betreff', // Subject,
'' // ParamStr(0) Attachment
);
SendOk := smtp.SendEmail;
smtp.free;
... }
{------------------------------------------------------------------------------}
{ End of Module Details }
{------------------------------------------------------------------------------}
unit Email;
interface
uses
Windows, WinSock, SysUtils;
type
TSMTPEngine =
class // socket and file access threadsave implemented
private
FSock : TSocket;
FFileBuf : AnsiString;
FServerIP , FRecip, FBody, FFrom, FCc, FSubject, FAttachment:
String;
function SendData(STR:
string): Boolean;
function CheckRecv(
const Code:
string): Boolean;
function ExtractFileName(
const FileName: ShortString):
String;
function Base64Encode(Input :
String) :
String;
function CheckIPEx(s:
string): Boolean;
function GetIPFromHost(
const HostName:
string):
string;
function FileExists(
const FileName:
string): Boolean;
public
constructor Create(
const server, Recip, Body, From,
Cc, Subject, Attachment:
String);
destructor Destroy;
Override;
function SendEmail : Boolean;
end;
implementation
type
TLookup =
array [0..64]
of Char;
const
Base64Out: TLookup =
(
'
A', '
B', '
C', '
D', '
E', '
F', '
G', '
H', '
I', '
J', '
K', '
L', '
M',
'
N', '
O', '
P', '
Q', '
R', '
S', '
T', '
U', '
V', '
W', '
X', '
Y', '
Z',
'
a', '
b', '
c', '
d', '
e', '
f', '
g', '
h', '
i', '
j', '
k', '
l', '
m',
'
n', '
o', '
p', '
q', '
r', '
s', '
t', '
u', '
v', '
w', '
x', '
y', '
z',
'
0', '
1', '
2', '
3', '
4', '
5', '
6', '
7', '
8', '
9', '
+', '
/', '
='
);
var
_SocketLock: TRTLCriticalSection;
function TSMTPEngine.FileExists(
const FileName:
string): Boolean;
begin
Result := FileAge(FileName) <> -1;
end;
function TSMTPEngine.SendData(STR:
string) : Boolean;
var
cbSent: integer;
begin
EnterCriticalSection(_SocketLock);
try
cbSent := Send(FSock, STR[1], Length(STR), 0);
if ((cbSent <> SOCKET_ERROR)
and (cbSent = Length(STR)))
then Result := True
else Result := False;
finally
LeaveCriticalSection(_SocketLock);
end;
end;
function TSMTPEngine.ExtractFileName(
const FileName: ShortString):
String;
var
I: Integer;
begin
I := Length(FileName);
while (I >= 1)
and not(FileName[I]
in ['
\', '
:'])
do Dec(I);
Result := Copy(FileName, I + 1, 255);
end;
function TSMTPEngine.CheckRecv(
const Code:
string): Boolean;
var
Buf :
array [0..4096]
of Char;
begin
ZeroMemory(@Buf[0], SizeOf(Buf));
EnterCriticalSection(_SocketLock);
try
if (Recv(FSock, Buf, SizeOf(Buf), 0) = SOCKET_ERROR)
or (Copy(Buf, 1, 3) <> Code)
then
Result := False
else Result := True;
finally
LeaveCriticalSection(_SocketLock);
end;
{$IFDEF ConsoleDebug}
Write(Buf);
{$ENDIF}
end;
function TSMTPEngine.Base64Encode(Input :
String) :
String;
var
Final :
String;
Count : Integer;
Len : Integer;
begin
Final := '
';
Count := 1;
Len := Length(Input);
while Count <= Len
do begin
Final :=
Final + Base64Out[(Byte(Input[Count])
and $FC)
shr 2];
if (Count + 1) <= Len
then begin
Final :=
Final + Base64Out[((Byte(Input[Count])
and $03)
shl 4) +
((Byte(Input[Count+1])
and $F0)
shr 4)];
if (Count+2) <= Len
then begin
Final :=
Final + Base64Out[((Byte(Input[Count+1])
and $0F)
shl 2) +
((Byte(Input[Count+2])
and $C0)
shr 6)];
Final :=
Final + Base64Out[(Byte(Input[Count+2])
and $3F)];
end
else begin
Final :=
Final + Base64Out[(Byte(Input[Count+1])
and $0F)
shl 2];
Final :=
Final + '
=';
end
end
else begin
Final :=
Final + Base64Out[(Byte(Input[Count])
and $03)
shl 4];
Final :=
Final + '
==';
end;
Count := Count + 3;
end;
Result :=
Final;
end;
function TSMTPEngine.SendEmail: Boolean;
var
F :
file;
WSAData : TWSAData;
P : AnsiString;
SockAddrIn : TSockAddrIn;
LocalHost :
array [0..63]
of CHAR;
begin
Result := False;
{$IFDEF ConsoleDebug}
Writeln('
Send mail:'#13#10);
{$ENDIF}
WSAStartUp(257, WSAData);
try
GetHostName(
LocalHost, SizeOf(
LocalHost));
FSock := Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
SockAddrIn.sin_family := AF_INET;
SockAddrIn.sin_port := htons(25);
SockAddrIn.sin_addr.S_addr := inet_addr(pChar(FServerIP));
// allways us ip
Connect(FSock, SockAddrIn, SizeOf(SockAddrIn));
if not CheckRecv('
220')
then EXIT;
if not SendData('
HELO ' +
LocalHost + #13#10)
then EXIT;
if not CheckRecv('
250')
then EXIT;
if not SendData('
MAIL FROM: <' + FFrom + '
>'#13#10)
then EXIT;
if not CheckRecv('
250')
then EXIT;
if not SendData('
RCPT TO: <' + FRecip + '
>'#13#10)
then EXIT;
if not CheckRecv('
250')
then EXIT;
if not SendData('
DATA'#13#10)
then EXIT;
if not CheckRecv('
354')
then EXIT;
if FileExists(FAttachment)
then begin // with attachment
if not SendData(
'
From: ' + FFrom + #13#10 +
'
To: ' + FRecip + #13#10 +
'
Cc: ' + FCc + #13#10 +
'
Subject: ' + FSubject + #13#10 +
'
MIME-Version: 1.0'#13#10 +
'
Content-type: multipart/mixed; boundary="bla"'#13#10#13#10 +
'
--bla'#13#10 +
'
Content-type: text/plain; charset:us-ascii'#13#10#13#10 +
FBody + #13#10#13#10 +
'
--bla'+#13#10 +
'
Content-type: application/x-shockwave-flash;'#13#10 +
'
name="' + ExtractFileName(FAttachment) + '
"'#13#10 +
'
Content-Transfer-Encoding: base64'#13#10#13#10
)
then EXIT;
EnterCriticalSection(_SocketLock);
try
AssignFile(F, FAttachment);
FileMode := 0;
try
Reset(F, 1);
if IOResult = 0
then begin
SetLength(FFileBuf, FileSize(F));
BlockRead(F, FFileBuf[1], FileSize(F));
p := Base64Encode(FFileBuf);
if not SendData(P)
then EXIT;
CloseFile(F);
end;
except
EXIT;
end;
finally
LeaveCriticalSection(_SocketLock);
end;
end else begin // without attachment
if not SendData(
'
From: ' + FFrom + #13#10 +
'
To: ' + FRecip + #13#10+
'
Cc: ' + FCc + #13#10+
'
Subject: ' + FSubject + #13#10 +
'
MIME-Version: 1.0'#13#10 +
'
Content-type: multipart/mixed; boundary="bla"'#13#10#13#10 +
'
--bla'#13#10 +
'
Content-type: text/plain; charset:us-ascii'#13#10#13#10 +
FBody + #13#10#13#10
)
then EXIT;
end;
if not SendData(#13#10'
--bla--'#13#10'
.'#13#10)
then EXIT;
if not CheckRecv('
250')
then EXIT;
if not SendData('
QUIT'#13#10)
then EXIT;
closesocket(FSock);
Result := True;
finally
WSACleanup();
end;
end;
// This function is optimized for speed
function TSMTPEngine.CheckIPEx(s:
string): Boolean;
var
s1, s2, s3, s4:
String;
e, v, i, j: Integer;
bcLen: integer;
ix:
array[1..3]
of integer;
begin
result := false;
j := 0;
bcLen := Length(s);
for i:= 1
to bcLen
do begin
if s[i]= '
.'
then begin
inc(j);
ix[j] := i;
end;
end;
if j <> 3
then EXIT;
s1 := copy(s, 1, ix[1] - 1);
s2 := copy(s, ix[1] + 1, ix[2] - ix[1] - 1);
s3 := copy(s, ix[2] + 1, ix[3] - ix[2] - 1);
s4 := copy(s, ix[3] + 1, bcLen);
Val(s1, v, e);
if (e <> 0)
or (v > 255)
or (v < 0)
or ((Length(s1) > 1)
and (s1[1] = '
0'))
then EXIT;
Val(s2, v, e);
if (e <> 0)
or (v > 255)
or (v < 0)
or ((Length(s2) > 1)
and (s2[1] = '
0'))
then EXIT;
Val(s3, v, e);
if (e <> 0)
or (v > 255)
or (v < 0)
or ((Length(s3) > 1)
and (s3[1] = '
0'))
then EXIT;
Val(s4, v, e);
if (e <> 0)
or (v > 255)
or (v < 0)
or ((Length(s4) > 1)
and (s4[1] = '
0'))
then EXIT;
result := true;
end;
function TSMTPEngine.GetIPFromHost(
const HostName:
string):
string;
type
TaPInAddr =
array[0..10]
of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
i: Integer;
GInitData: TWSAData;
begin
WSAStartup($101, GInitData);
Result := '
';
phe := GetHostByName(PChar(HostName));
if phe =
nil then Exit;
pPtr := PaPInAddr(phe^.h_addr_list);
i := 0;
while pPtr^[i] <>
nil do
begin
Result := inet_ntoa(pptr^[i]^);
Inc(i);
end;
WSACleanup;
end;
constructor TSMTPEngine.Create(
const Server, Recip, Body, From,
Cc, Subject, Attachment :
String);
begin
inherited create;
if not CheckIPEx(Server)
then begin
FServerIP := GetIPFromHost(Server);
end else
FServerIP := Server;
FRecip := Recip;
FBody := Body;
FFrom := From;
FCc :=
Cc;
FSubject := Subject;
FAttachment := Attachment;
end;
destructor TSMTPEngine.Destroy;
begin
inherited;
end;
initialization
InitializeCriticalSection(_SocketLock);
finalization
DeleteCriticalSection(_SocketLock);
end.