Archivado/Componentes.Terceros.UserControl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
cc4a514b7b
Componentes.Terceros.UserCo.../internal/2.31RC1/1/Source/UCALSMTPClient.pas

3771 lines
118 KiB
ObjectPascal
Raw Normal View History

- Compilación para D2009 - UCBase.pas -> Modificado el formato de las fechas de 'dd/mm/yyyy' a 'mm/dd/yyyy' para que funcione con Firebird. - UCBase.pas -> Cuando se llama a DelCurrentUser comprobar que realmente hay un usuario registrado. git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.UserControl@22 970f2627-a9d2-4748-b3d4-b5283c4fe7db
2009-03-01 17:39:41 +00:00
{*************************************************************
Author: St<EFBFBD>phane Vander Clock (SVanderClock@Arkadia.com)
Contributor Fran<EFBFBD>ois PIETTE (http://www.overbyte.be)
Paul TOTH (tothpaul@free.fr - http://tothpaul.free.fr)
EMail: http://www.arkadia.com
SVanderClock@Arkadia.com
product: TALSMTPClient
Version: 3.05
Description: TALsmtpClient class implements the SMTP protocol (RFC-821)
Support file attachement using MIME format (RFC-1521, RFC-2045)
Support authentification (RFC-2104)
Legal issues: Copyright (C) 2005 by St<EFBFBD>phane Vander Clock
This software is provided 'as-is', without any express
or implied warranty. In no event will the author be
held liable for any damages arising from the use of
this software.
Permission is granted to anyone to use this software
for any purpose, including commercial applications,
and to alter it and redistribute it freely, subject
to the following restrictions:
1. The origin of this software must not be
misrepresented, you must not claim that you wrote
the original software. If you use this software in
a product, an acknowledgment in the product
documentation would be appreciated but is not
required.
2. Altered source versions must be plainly marked as
such, and must not be misrepresented as being the
original software.
3. This notice may not be removed or altered from any
source distribution.
4. You must register this software by sending a picture
postcard to the author. Use a nice stamp and mention
your name, street address, EMail address and any
comment you like to say.
Know bug :
History :
Link : http://linuxgazette.net/issue45/stumpel.html
http://www.overbyte.be
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/socket_options.asp
http://www.fehcom.de/qmail/smtpauth.html
http://www.freesoft.org/CIE/RFC/821/
http://www.expita.com/header1.html
http://cr.yp.to/immhf.html
Please send all your feedback to SVanderClock@Arkadia.com
**************************************************************}
{$I 'UserControl.inc'}
unit UCALSMTPClient;
interface
uses
Classes,
Dialogs,
sysutils,
windows,
WinSock;
type
{Note: when changing TVendor, also change VendorStr array below}
TALCPUVendor = (
cvUnknown,
cvAMD,
cvCentaur,
cvCyrix,
cvIntel,
cvTransmeta,
cvNexGen,
cvRise,
cvUMC,
cvNSC,
cvSiS
);
{Note: when changing TInstruction, also change InstructionSupportStr below
* - instruction(s) not supported in Delphi 7 assembler}
TALCPUInstructions = (
isFPU, {80x87}
isTSC, {RDTSC}
isCX8, {CMPXCHG8B}
isSEP, {SYSENTER/SYSEXIT}
isCMOV, {CMOVcc, and if isFPU, FCMOVcc/FCOMI}
isMMX, {MMX}
isFXSR, {FXSAVE/FXRSTOR}
isSSE, {SSE}
isSSE2, {SSE2}
isSSE3, {SSE3*}
isMONITOR, {MONITOR/MWAIT*}
isCX16, {CMPXCHG16B*}
isX64, {AMD AMD64* or Intel EM64T*}
isExMMX, {MMX+ - AMD only}
isEx3DNow, {3DNow!+ - AMD only}
is3DNow {3DNow! - AMD only}
);
TALCPUInstructionSupport = set of TALCPUInstructions;
TALCPUInfo = record
Vendor: TALCPUVendor;
Signature: cardinal;
EffFamily: byte; {ExtendedFamily + Family}
EffModel: byte; {(ExtendedModel shl 4) + Model}
CodeL1CacheSize, {KB or micro-ops for Pentium 4}
DataL1CacheSize, {KB}
L2CacheSize, {KB}
L3CacheSize: Word; {KB}
InstructionSupport: TALCPUInstructionSupport;
end;
TALHandleTagfunct = function(const TagString: String; TagParams: TStrings; ExtData: pointer; var Handled: Boolean): String;
TALMoveProc = procedure(const Source; var Dest; Count: Integer);
TALCharPosFunct = function(Ch: char; const Str: ansistring): Integer;
TALPosFunct = function(const SubStr: ansistring; const Str: ansistring): Integer;
PALMimeBase64Byte4 = ^TALMimeBase64Byte4;
TALMimeBase64Byte4 = packed record
b1: byte;
b2: byte;
b3: byte;
b4: byte;
end;
PALMimeBase64Byte3 = ^TALMimeBase64Byte3;
TALMimeBase64Byte3 = packed record
b1: byte;
b2: byte;
b3: byte;
end;
{-----------------------}
TAlSmtpClientAuthType = (
AlsmtpClientAuthNone,
alsmtpClientAuthPlain,
AlsmtpClientAuthLogin,
AlsmtpClientAuthCramMD5,
AlsmtpClientAuthCramSha1,
AlsmtpClientAuthAutoSelect
);
{------------------------------------------------------}
TAlSmtpClientAuthTypeSet = set of TAlSmtpClientAuthType;
{--------------------------------------}
TALSMTPClientHeader = class(TPersistent)
private
fSendTo: String;
fSender: String;
fMessageID: String;
fbcc: String;
fContentTransferEncoding: String;
fComments: String;
fMIMEVersion: String;
fPriority: String;
fReplyTo: String;
fSubject: String;
fFrom: String;
fDate: String;
fDispositionNotificationTo: String;
fReferences: String;
fcc: String;
fContentType: String;
FCustomHeaders: TStrings;
function GetRawHeaderText: String;
procedure SetRawHeaderText(const aRawHeaderText: String);
protected
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear;
published
property From: String Read fFrom Write fFrom; {From: John Doe <jdoe@machine.example> - Author(s) or person(s) taking responsibility for the message 4.4.1; RFC 1123: 5.2.15-16, 5.3.7; RFC 1036: 2.1.1}
property Sender: String Read fSender Write fSender; {Sender: Michael Jones <mjones@machine.example> - The person or agent submitting the message to the network, if other than shown by the From header RFC 822: 4.4.2; RFC 1123: 5.2.15-16, 5.3.7; RFC 1036: 2.1.1}
property SendTo: String Read fSendTo Write fSendTo; {To: Mary Smith <mary@example.net> - Primary recipient(s) RFC 822: 4.5.1; RFC 1123: 5.2.15-16, 5.3.7;}
property cc: String Read fcc Write fcc; {cc: <boss@nil.test>, "Giant; \"Big\" Box" <sysservices@example.net> - Secondary, informational recipient(s) RFC 822: 4.5.2; RFC 1123: 5.2.15-16, 5.3.7;}
property bcc: String Read fbcc Write fbcc; {bcc: <boss@nil.test>, "Giant; \"Big\" Box" <sysservices@example.net> - Recipient(s) not to be disclosed to other recipients ("blind carbon copy") RFC 822: 4.5.3; RFC 1123: 5.2.15-16, 5.3.7;}
property ReplyTo: String Read fReplyTo Write fReplyTo; {Reply-To: "Mary Smith: Personal Account" <smith@home.example> - Suggested E-mail address for replies RFC 822: 4.4.3; RFC 1036: 2.2.1}
property Subject: String Read fSubject Write fSubject; {Subject: Saying Hello - Text that provides a summary, or indicates the nature, of the message RFC 822: 4.7.1; RFC 1036: 2.1.4}
property MessageID: String Read fMessageID Write fMessageID; {Message-ID: <1234@local.machine.example> - Unique ID for the message RFC 822: 4.6.1; RFC 1036: 2.1.5}
property References: String Read fReferences Write fReferences; {References: <1234@local.machine.example> <3456@example.net> - In E-mail: reference to other related messages; in Usenet: reference to replied-to-articles RFC 822: 4.6.3; RFC 1036: 2.2.5}
property Comments: String Read fComments Write fComments; {Comments: Authenticated sender is gboyd@netcom.com - Text comments added to the message RFC 822: 4.7.2}
property Date: String Read fDate Write fDate; {Date: Fri, 21 Nov 1997 09:55:06 -0600 - The time when the message was written (or submitted) RFC 822: 5.1; RFC 1123: 5.2.14; RFC 1036: 2.1.2}
property ContentType: String Read fContentType Write fContentType; {Content-Type: text/plain; charset="iso-8859-1" - Data type and format of content RFC 1049 (historic); RFC 1123: 5.2.13; RFC 2045: 5; RFC 1766: 4.1}
property ContentTransferEncoding: String Read fContentTransferEncoding Write fContentTransferEncoding; {Content-Transfer-Encoding: 8bit - Coding method used in a MIME message body RFC 2045: 6;}
property MIMEVersion: String Read fMIMEVersion Write fMIMEVersion; {MIME-Version: 1.0 - specifies the version of MIME that the message format complies with RFC 2045: 4}
property Priority: String Read fPriority Write fPriority; {Priority: normal - Priority for message delivery ("normal" / "non-urgent" / "urgent") RFC 2156}
property DispositionNotificationTo: String Read fDispositionNotificationTo Write fDispositionNotificationTo; {Disposition-Notification-To: boss@nil.test - Requests for notification when the message is received, and specifies the address for them RFC 2298}
property CustomHeaders: TStrings Read FCustomHeaders;
property RawHeaderText: String Read GetRawHeaderText Write SetRawHeaderText;
end;
TOnStatus = procedure(Status: String) of object;
{----------------------------}
TAlSmtpClient = class(TObject)
private
FWSAData: TWSAData;
Fconnected: Boolean;
FSocketDescriptor: Integer;
FAuthTypesSupported: TAlSmtpClientAuthTypeSet;
Ftimeout: Integer;
fOnStatus: TOnStatus;
procedure Settimeout(const Value: Integer);
protected
procedure CheckError(Error: Boolean);
function SendCmd(aCmd: String; OkResponses: array of Word): String; virtual;
function GetResponse(OkResponses: array of Word): String;
function SocketWrite(var Buffer; Count: longint): longint; virtual;
function SocketRead(var Buffer; Count: longint): longint; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
function Connect(aHost: String; APort: Integer): String; virtual;
function Helo: String; virtual;
function Ehlo: String; virtual;
function Auth(AUserName, APassword: String; aAuthType: TalSmtpClientAuthType): String; virtual;
function Vrfy(aUserName: String): String; virtual;
function MailFrom(aFromName: String): String; virtual;
function RcptTo(aRcptNameLst: TStrings): String; virtual;
function Data(aMailData: String): String; overload; virtual;
function Data(aHeader, aBody: String): String; overload; virtual;
function Data(aHeader: TALSMTPClientHeader; aBody: String): String; overload; virtual;
function Quit: String; virtual;
function Rset: String; virtual;
procedure SendMail(aHost: String; APort: Integer; aFromName: String; aRcptNameLst: TStrings; AUserName, APassword: String; aAuthType: TalSmtpClientAuthType; aMailData: String); overload; virtual;
procedure SendMail(aHost: String; APort: Integer; aFromName: String; aRcptNameLst: TStrings; AUserName, APassword: String; aAuthType: TalSmtpClientAuthType; aHeader, aBody: String); overload; virtual;
procedure Disconnect; virtual;
function GetAuthTypeFromEhloResponse(EhloResponse: String): TAlSmtpClientAuthTypeSet; virtual;
property Connected: Boolean Read FConnected;
property Timeout: Integer Read Ftimeout Write Settimeout default 60000;
property OnStatus: TOnStatus Read fOnStatus Write fOnStatus;
end;
{----------------------------------------------------------------------------------------}
function AlSMTPClientParseEmail(FriendlyEmail: String; var FriendlyName: String): String;
function AlSMTPClientGenerateMessageID: String;
var
ALMove: TALMoveProc;
ALCharPos: TALCharPosFunct;
ALPos: TALPosFunct;
implementation
uses
HTTPAPP;
//***********************************************************************
//AlFcnWinSock Partial Unit
//***********************************************************************
function ALgetLocalHostName: String;
var
{$IFDEF DELPHI12}
Buffer : pAnsichar;
{$ELSE}
Buffer : array [0..255] of char;
{$ENDIF}
WSAData : TWSAData;
begin
WSAData.wVersion := 0;
WSAStartup(MAKEWORD(2, 2), WSAData);
try
if gethostname(Buffer, SizeOf(Buffer)) <> 0 then
raise Exception.Create('Winsock GetHostName failed');
Result := StrPas(Buffer);
finally
if WSAData.wVersion = 2 then
WSACleanup;
end;
end;
function ALHostToIP(HostName: String; var Ip: String): Boolean;
var
WSAData: TWSAData;
hostEnt: PHostEnt;
{$IFDEF DELPHI12} addr: PAnsiChar; {$ELSE} addr: PChar; {$ENDIF}
begin
WSAData.wVersion := 0;
WSAStartup(MAKEWORD(2, 2), WSAData);
try
{$IFDEF DELPHI12}
hostEnt := gethostbyname(PAnsiChar(hostName));
{$ELSE}
hostEnt := gethostbyname(PChar(hostName));
{$ENDIF}
if Assigned(hostEnt) then
begin
if Assigned(hostEnt^.h_addr_list) then
begin
{$IFDEF DELPHI12}
addr := hostEnt^.h_addr_list^;
{$ELSE}
addr := hostEnt^.h_addr_list^;
{$ENDIF}
if Assigned(addr) then
begin
IP := Format('%d.%d.%d.%d', [byte(addr[0]),
byte(addr[1]), byte(addr[2]), byte(addr[3])]);
Result := True;
end
else
Result := False;
end
else
Result := False;
end
else
Result := False;
finally
if WSAData.wVersion = 2 then
WSACleanup;
end;
end;
//***********************************************************************
//AlFcnRFC Partial Unit
//***********************************************************************
const
CAlRfc822DaysOfWeek: array[1..7] of String = (
'Sun',
'Mon',
'Tue',
'Wed',
'Thu',
'Fri',
'Sat'
);
CALRfc822MonthNames: array[1..12] of String = (
'Jan',
'Feb',
'Mar',
'Apr',
'May',
'Jun',
'Jul',
'Aug',
'Sep',
'Oct',
'Nov',
'Dec'
);
function ALGMTDateTimeToRfc822Str(const aValue: TDateTime): String;
var
aDay, aMonth, aYear: Word;
begin
DecodeDate(
aValue,
aYear,
aMonth,
aDay
);
Result := Format(
'%s, %.2d %s %.4d %s %s',
[
CAlRfc822DaysOfWeek[DayOfWeek(aValue)],
aDay,
CAlRfc822MonthNames[aMonth],
aYear,
FormatDateTime('hh":"nn":"ss', aValue),
'GMT'
]
);
end;
function ALDateTimeToRfc822Str(const aValue: TDateTime): String;
{--------------------------------------------}
function InternalCalcTimeZoneBias: TDateTime;
const
Time_Zone_ID_DayLight = 2;
var
TZI: TTimeZoneInformation;
TZIResult: Integer;
aBias: Integer;
begin
TZIResult := GetTimeZoneInformation(TZI);
if TZIResult = -1 then
Result := 0
else
begin
if TZIResult = Time_Zone_ID_DayLight then
aBias := TZI.Bias + TZI.DayLightBias
else
aBias := TZI.Bias + TZI.StandardBias;
Result := EncodeTime(Abs(aBias) div 60, Abs(aBias) mod 60, 0, 0);
if aBias < 0 then
Result := -Result;
end;
end;
begin
Result := ALGMTDateTimeToRfc822Str(aValue + InternalCalcTimeZoneBias);
end;
//***********************************************************************
//AlFcnMime Partial Unit
//***********************************************************************
const
cALMime_Base64_Encode_Table: array[0..63] of byte = (
065, 066, 067, 068, 069, 070, 071, 072, // 00 - 07
073, 074, 075, 076, 077, 078, 079, 080, // 08 - 15
081, 082, 083, 084, 085, 086, 087, 088, // 16 - 23
089, 090, 097, 098, 099, 100, 101, 102, // 24 - 31
103, 104, 105, 106, 107, 108, 109, 110, // 32 - 39
111, 112, 113, 114, 115, 116, 117, 118, // 40 - 47
119, 120, 121, 122, 048, 049, 050, 051, // 48 - 55
052, 053, 054, 055, 056, 057, 043, 047 // 56 - 63
);
cALMime_Base64_Pad_Char = byte('=');
function ALMimeBase64EncodedSizeNoCRLF(const InputSize: cardinal): cardinal;
begin
Result := (InputSize + 2) div 3 * 4;
end;
procedure ALMimeBase64EncodeNoCRLF(const InputBuffer; const InputByteCount: cardinal; out OutputBuffer);
var
B, InnerLimit, OuterLimit: cardinal;
InPtr: PALMimeBase64Byte3;
OutPtr: PALMimeBase64Byte4;
begin
if InputByteCount = 0 then
Exit;
InPtr := @InputBuffer;
OutPtr := @OutputBuffer;
OuterLimit := InputByteCount div 3 * 3;
InnerLimit := cardinal(InPtr);
Inc(InnerLimit, OuterLimit);
{ Last line loop. }
while cardinal(InPtr) < InnerLimit do
begin
{ Read 3 bytes from InputBuffer. }
B := InPtr^.b1;
B := B shl 8;
B := B or InPtr^.b2;
B := B shl 8;
B := B or InPtr^.b3;
Inc(InPtr);
{ Write 4 bytes to OutputBuffer (in reverse order). }
OutPtr^.b4 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr^.b3 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr^.b2 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr^.b1 := CALMIME_Base64_ENCODE_TABLE[B];
Inc(OutPtr);
end;
{ End of data & padding. }
case InputByteCount - OuterLimit of
1:
begin
B := InPtr^.b1;
B := B shl 4;
OutPtr.b2 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr.b1 := CALMIME_Base64_ENCODE_TABLE[B];
OutPtr.b3 := CALMIME_Base64_PAD_CHAR; { Pad remaining 2 bytes. }
OutPtr.b4 := CALMIME_Base64_PAD_CHAR;
end;
2:
begin
B := InPtr^.b1;
B := B shl 8;
B := B or InPtr^.b2;
B := B shl 2;
OutPtr.b3 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr.b2 := CALMIME_Base64_ENCODE_TABLE[B and $3F];
B := B shr 6;
OutPtr.b1 := CALMIME_Base64_ENCODE_TABLE[B];
OutPtr.b4 := CALMIME_Base64_PAD_CHAR; { Pad remaining byte. }
end;
end;
end;
function ALMimeBase64EncodeStringNoCRLF(const S: ansistring): ansistring;
var
L: cardinal;
begin
if Pointer(S) <> nil then
begin
L := PCardinal(cardinal(S) - 4)^;
SetLength(Result, ALMimeBase64EncodedSizeNoCRLF(L));
ALMimeBase64EncodeNoCRLF(Pointer(S)^, L, Pointer(Result)^);
end
else
Result := '';
end;
//***********************************************************************
//ALFcnMisc Partial Unit
//***********************************************************************
function ALMakeKeyStrByGUID: String;
var
aGUID: TGUID;
begin
CreateGUID(aGUID);
Result := GUIDToString(aGUID);
Delete(Result, 1, 1);
Delete(Result, Length(Result), 1);
end;
//***********************************************************************
//ALFCNString Partial Unit
//***********************************************************************
{-------------------------------}
const
CALMOVE_SMALLMOVESIZE = 36;
{-------------------------------------------------}
var
VALMove_AnsiUpcase: packed array[char] of char;
// VALMove_PrefetchLimit: Integer;
//////////////////////////////////////////////////////////////////////////////////////////////////////
//////////ALPosEx from FastCode AINSIStringReplace John O'Harrow (john@almcrest.demon.co.uk)//////////
//////////////////////////////////////////////////////////////////////////////////////////////////////
{*********************************}
{Fast Equivalent of Delphi 7 PosEx}
function ALPosEx(const SubStr, S: String; Offset: cardinal = 1): Integer;
asm
push ebx
push esi
push edx {@Str}
test eax, eax
jz @@NotFound {Exit if SubStr = ''}
test edx, edx
jz @@NotFound {Exit if Str = ''}
mov esi, ecx
mov ecx, [edx-4] {Length(Str)}
mov ebx, [eax-4] {Length(SubStr)}
add ecx, edx
sub ecx, ebx {Max Start Pos for Full Match}
lea edx, [edx+esi-1] {Set Start Position}
cmp edx, ecx
jg @@NotFound {StartPos > Max Start Pos}
cmp ebx, 1 {Length(SubStr)}
jle @@SingleChar {Length(SubStr) <= 1}
push edi
push ebp
lea edi, [ebx-2] {Length(SubStr) - 2}
mov esi, eax
movzx ebx, [eax] {Search Character}
@@Loop: {Compare 2 Characters per Loop}
cmp bl, [edx]
jne @@NotChar1
mov ebp, edi {Remainder}
@@Char1Loop:
movzx eax, word ptr [esi+ebp]
cmp ax, [edx+ebp]
jne @@NotChar1
sub ebp, 2
jnc @@Char1Loop
pop ebp
pop edi
jmp @@SetResult
@@NotChar1:
cmp bl, [edx+1]
jne @@NotChar2
mov ebp, edi {Remainder}
@@Char2Loop:
movzx eax, word ptr [esi+ebp]
cmp ax, [edx+ebp+1]
jne @@NotChar2
sub ebp, 2
jnc @@Char2Loop
pop ebp
pop edi
jmp @@CheckResult
@@NotChar2:
add edx, 2
cmp edx, ecx {Next Start Position <= Max Start Position}
jle @@Loop
pop ebp
pop edi
jmp @@NotFound
@@SingleChar:
jl @@NotFound {Needed for Zero-Length Non-NIL Strings}
movzx eax, [eax] {Search Character}
@@CharLoop:
cmp al, [edx]
je @@SetResult
cmp al, [edx+1]
je @@CheckResult
add edx, 2
cmp edx, ecx
jle @@CharLoop
@@NotFound:
xor eax, eax
pop edx
pop esi
pop ebx
ret
@@CheckResult: {Check within String}
cmp edx, ecx
jge @@NotFound
add edx, 1
@@SetResult:
pop ecx {@Str}
pop esi
pop ebx
neg ecx
lea eax, [edx+ecx+1]
end;
{***********************************}
{Non Case Sensitive version of PosEx}
function ALPosExIgnoreCase(const SubStr, S: String; Offset: cardinal = 1): Integer;
asm
push ebx
push esi
push edx {@Str}
test eax, eax
jz @@NotFound {Exit if SubStr = ''}
test edx, edx
jz @@NotFound {Exit if Str = ''}
mov esi, ecx
mov ecx, [edx-4] {Length(Str)}
mov ebx, [eax-4] {Length(SubStr)}
add ecx, edx
sub ecx, ebx {Max Start Pos for Full Match}
lea edx, [edx+esi-1] {Set Start Position}
cmp edx, ecx
jg @@NotFound {StartPos > Max Start Pos}
cmp ebx, 1 {Length(SubStr)}
jle @@SingleChar {Length(SubStr) <= 1}
push edi
push ebp
lea edi, [ebx-2] {Length(SubStr) - 2}
mov esi, eax
push edi {Save Remainder to Check = Length(SubStr) - 2}
push ecx {Save Max Start Position}
lea edi, VALMove_AnsiUpcase {Uppercase Lookup Table}
movzx ebx, [eax] {Search Character = 1st Char of SubStr}
movzx ebx, [edi+ebx] {Convert to Uppercase}
@@Loop: {Loop Comparing 2 Characters per Loop}
movzx eax, [edx] {Get Next Character}
movzx eax, [edi+eax] {Convert to Uppercase}
cmp eax, ebx
jne @@NotChar1
mov ebp, [esp+4] {Remainder to Check}
@@Char1Loop:
movzx eax, [esi+ebp]
movzx ecx, [edx+ebp]
movzx eax, [edi+eax] {Convert to Uppercase}
movzx ecx, [edi+ecx] {Convert to Uppercase}
cmp eax, ecx
jne @@NotChar1
movzx eax, [esi+ebp+1]
movzx ecx, [edx+ebp+1]
movzx eax, [edi+eax] {Convert to Uppercase}
movzx ecx, [edi+ecx] {Convert to Uppercase}
cmp eax, ecx
jne @@NotChar1
sub ebp, 2
jnc @@Char1Loop
pop ecx
pop edi
pop ebp
pop edi
jmp @@SetResult
@@NotChar1:
movzx eax, [edx+1] {Get Next Character}
movzx eax, [edi+eax] {Convert to Uppercase}
cmp bl, al
jne @@NotChar2
mov ebp, [esp+4] {Remainder to Check}
@@Char2Loop:
movzx eax, [esi+ebp]
movzx ecx, [edx+ebp+1]
movzx eax, [edi+eax] {Convert to Uppercase}
movzx ecx, [edi+ecx] {Convert to Uppercase}
cmp eax, ecx
jne @@NotChar2
movzx eax, [esi+ebp+1]
movzx ecx, [edx+ebp+2]
movzx eax, [edi+eax] {Convert to Uppercase}
movzx ecx, [edi+ecx] {Convert to Uppercase}
cmp eax, ecx
jne @@NotChar2
sub ebp, 2
jnc @@Char2Loop
pop ecx
pop edi
pop ebp
pop edi
jmp @@CheckResult {Check Match is within String Data}
@@NotChar2:
add edx, 2
cmp edx, [esp] {Compate to Max Start Position}
jle @@Loop {Loop until Start Position > Max Start Position}
pop ecx {Dump Start Position}
pop edi {Dump Remainder to Check}
pop ebp
pop edi
jmp @@NotFound
@@SingleChar:
jl @@NotFound {Needed for Zero-Length Non-NIL Strings}
lea esi, VALMove_AnsiUpcase
movzx ebx, [eax] {Search Character = 1st Char of SubStr}
movzx ebx, [esi+ebx] {Convert to Uppercase}
@@CharLoop:
movzx eax, [edx]
movzx eax, [esi+eax] {Convert to Uppercase}
cmp eax, ebx
je @@SetResult
movzx eax, [edx+1]
movzx eax, [esi+eax] {Convert to Uppercase}
cmp eax, ebx
je @@CheckResult
add edx, 2
cmp edx, ecx
jle @@CharLoop
@@NotFound:
xor eax, eax
pop edx
pop esi
pop ebx
ret
@@CheckResult: {Check Match is within String Data}
cmp edx, ecx
jge @@NotFound
add edx, 1 {OK - Adjust Result}
@@SetResult: {Set Result Position}
pop ecx {@Str}
pop esi
pop ebx
neg ecx
lea eax, [edx+ecx+1]
end;
///////////////////////////////////////////////////////////////////////////////////////////////
//////////AlFastStringReplace from FastCode John O'Harrow (john@almcrest.demon.co.uk)//////////
///////////////////////////////////////////////////////////////////////////////////////////////
{****************************************}
{Non-Overlapping Move for Positive Counts}
procedure ALStringReplaceMoveEx(const Source; var Dest; Count: Integer);
const
SMALLMOVESIZE = 16;
asm
cmp ecx, SMALLMOVESIZE
ja @Large
lea eax, [eax+ecx]
lea edx, [edx+ecx]
jmp dword ptr [@@FwdJumpTable+ecx*4]
@Large:
fild qword ptr [eax]
fistp qword ptr [edx]
add eax, ecx
add ecx, edx
add edx, 7+8
neg ecx
and edx, -8
add ecx, edx
sub edx, ecx {Writes Now QWORD Aligned}
@FwdLoop:
fild qword ptr [eax+ecx-8]
fistp qword ptr [edx+ecx-8]
add ecx, 8
jle @FwdLoop
neg ecx
add ecx, 8
jmp dword ptr [@@FwdJumpTable+ecx*4]
nop {Align Jump Table}
@@FwdJumpTable:
dd @@Done {Removes need to test for zero size Move}
dd @@Fwd01,@@Fwd02,@@Fwd03,@@Fwd04,@@Fwd05,@@Fwd06,@@Fwd07,@@Fwd08
dd @@Fwd09,@@Fwd10,@@Fwd11,@@Fwd12,@@Fwd13,@@Fwd14,@@Fwd15,@@Fwd16
@@Fwd16:
mov ecx,[eax-16]
mov[edx-16],ecx
@@Fwd12:
mov ecx,[eax-12]
mov[edx-12],ecx
@@Fwd08:
mov ecx,[eax-8]
mov[edx-8],ecx
@@Fwd04:
mov ecx,[eax-4]
mov[edx-4],ecx
ret
@@Fwd15:
mov ecx,[eax-15]
mov[edx-15],ecx
@@Fwd11:
mov ecx,[eax-11]
mov[edx-11],ecx
@@Fwd07:
mov ecx,[eax-7]
mov[edx-7],ecx
@@Fwd03:
movzx ecx, word ptr [eax-3]
mov[edx-3],cx
movzx ecx, byte ptr [eax-1]
mov[edx-1],cl
ret
@@Fwd14:
mov ecx,[eax-14]
mov[edx-14],ecx
@@Fwd10:
mov ecx,[eax-10]
mov[edx-10],ecx
@@Fwd06:
mov ecx,[eax-6]
mov[edx-6],ecx
@@Fwd02:
movzx ecx, word ptr [eax-2]
mov[edx-2],cx
ret
@@Fwd13:
mov ecx,[eax-13]
mov[edx-13],ecx
@@Fwd09:
mov ecx,[eax-9]
mov[edx-9],ecx
@@Fwd05:
mov ecx,[eax-5]
mov[edx-5],ecx
@@Fwd01:
movzx ecx, byte ptr [eax-1]
mov[edx-1],cl
@@Done:
end; {MoveEx}
{**************************************************************************}
{Replace all occurance of Old (Ignoring Case) with New in Non-Null String S}
{$IFDEF DELPHI12}
procedure ALCharReplaceIC(var S: ansistring; const Old, New: pAnsichar);
{$ELSE}
procedure ALCharReplaceIC(var S: ansistring; const Old, New: char);
{$ENDIF}
asm
push ebx
push edi
push esi
mov eax, [eax] {@S}
mov ebx, ecx {bl = New}
lea edi, VALMove_AnsiUpcase
and edx, $FF {edx = Old}
mov ecx, [eax-4] {Length(S)}
movzx edx, [edx+edi] {edx = Uppercase(Old)}
lea esi, [eax+ecx]
neg ecx
@@Loop:
movzx eax, [esi+ecx] {Next Char}
movzx eax, [eax+edi] {Convert to Uppercase}
cmp eax, edx {Compare Char}
jne @@Next
mov[esi+ecx], bl {Replace Char}
@@Next:
add ecx, 1
jnz @@Loop
pop esi
pop edi
pop ebx
end;
{***************************************************************************}
{Replace all occurance of Old (Case Sensitive) with New in Non-Null String S}
{$IFDEF DELPHI12}
procedure ALCharReplaceCS(var S: ansistring; const Old, New: pAnsichar);
{$ELSE}
procedure ALCharReplaceCS(var S: ansistring; const Old, New: char);
{$ENDIF}
asm
push ebx
mov eax, [eax] {@S}
mov ebx, ecx {bl = New, dl = Old}
mov ecx, [eax-4] {Length(S)}
add eax, ecx
neg ecx
@@Loop:
cmp dl, [eax+ecx] {Compare Next Char}
jne @@Next
mov[eax+ecx], bl {Replace Char}
@@Next:
add ecx, 1
jnz @@Loop
pop ebx
end;
{***************************************************************************************}
{from John O'Harrow (john@almcrest.demon.co.uk) - original name: StringReplaceJOH_IA32_4}
function ALStringReplace(const S, OldPattern, NewPattern: ansistring; Flags: TReplaceFlags): ansistring;
type
TPosEx = function(const SubStr, S: String; Offset: cardinal = 1): Integer;
{$IFDEF DELPHI12}
TCharRep = procedure(var S: ansistring; const Old, New: pAnsichar);
{$ELSE}
TCharRep = procedure(var S: ansistring; const Old, New: char);
{$ENDIF}
const
StaticBufferSize = 16;
PosExFunction: array[Boolean] of TPosEx = (ALPosEx, ALPosExIgnoreCase);
CharReplace: array[Boolean] of TCharRep = (ALCharReplaceCS, ALCharReplaceIC);
var
SrcLen, OldLen, NewLen, Found, Count, Start, Match, BufSize, BufMax: Integer;
StaticBuffer: array[0..StaticBufferSize - 1] of Integer;
Buffer: PIntegerArray;
{$IFDEF DELPHI12} PSrc, PRes: PAnsiChar; {$ELSE} PSrc, PRes: PChar; {$ENDIF}
IgnoreCase: Boolean;
begin
{$IFDEF ALStringReplace_AllowLengthShortcut}
SrcLen := 0;
if (S <> '') then
SrcLen := PCardinal(Cardinal(S)-4)^;
OldLen := 0;
if (OldPattern <> '') then
OldLen := PCardinal(Cardinal(OldPattern)-4)^;
NewLen := 0;
if (NewPattern <> '') then
NewLen := PCardinal(Cardinal(NewPattern)-4)^;
{$ELSE}
SrcLen := Length(S);
OldLen := Length(OldPattern);
NewLen := Length(NewPattern);
{$ENDIF}
if (OldLen = 0) or (SrcLen < OldLen) then
begin
if SrcLen = 0 then
Result := '' {Needed for Non-Nil Zero Length Strings}
else
Result := S;
end
else
begin
IgnoreCase := rfIgnoreCase in Flags;
if rfReplaceAll in Flags then
begin
if (OldLen = 1) and (NewLen = 1) then
begin
SetLength(Result, SrcLen);
ALStringReplaceMoveEx(Pointer(S)^, Pointer(Result)^, SrcLen);
{$IFDEF DELPHI12}
CharReplace[IgnoreCase](Result, pAnsiChar(OldPattern[1]), pAnsiChar(NewPattern[1]));
{$ELSE}
CharReplace[IgnoreCase](Result, OldPattern[1], NewPattern[1]);
{$ENDIF}
Exit;
end;
Found := PosExFunction[IgnoreCase](OldPattern, S, 1);
if Found <> 0 then
begin
Buffer := @StaticBuffer;
BufMax := StaticBufferSize;
BufSize := 1;
Buffer[0] := Found;
repeat
Inc(Found, OldLen);
Found := PosExFunction[IgnoreCase](OldPattern, S, Found);
if Found > 0 then
begin
if BufSize = BufMax then
begin {Create or Expand Dynamic Buffer}
BufMax := BufMax + (BufMax shr 1); {Grow by 50%}
if Buffer = @StaticBuffer then
begin {Create Dynamic Buffer}
GetMem(Buffer, BufMax * SizeOf(integer));
ALStringReplaceMoveEx(StaticBuffer, Buffer^, SizeOf(StaticBuffer));
end
else {Expand Dynamic Buffer}
ReallocMem(Buffer, BufMax * SizeOf(integer));
end;
Buffer[BufSize] := Found;
Inc(BufSize);
end
until Found = 0;
SetLength(Result, SrcLen + (BufSize * (NewLen - OldLen)));
PSrc := Pointer(S);
PRes := Pointer(Result);
Start := 1;
Match := 0;
repeat
Found := Buffer[Match];
Count := Found - Start;
Start := Found + OldLen;
if Count > 0 then
begin
ALStringReplaceMoveEx(PSrc^, PRes^, Count);
Inc(PRes, Count);
end;
Inc(PSrc, Count + OldLen);
ALStringReplaceMoveEx(Pointer(NewPattern)^, PRes^, NewLen);
Inc(PRes, NewLen);
Inc(Match);
until Match = BufSize;
Dec(SrcLen, Start);
if SrcLen >= 0 then
ALStringReplaceMoveEx(PSrc^, PRes^, SrcLen + 1);
if BufMax <> StaticBufferSize then
FreeMem(Buffer); {Free Dynamic Buffwe if Created}
end
else {No Matches Found}
Result := S;
end
else
begin {Replace First Occurance Only}
Found := PosExFunction[IgnoreCase](OldPattern, S, 1);
if Found <> 0 then
begin {Match Found}
SetLength(Result, SrcLen - OldLen + NewLen);
Dec(Found);
PSrc := Pointer(S);
PRes := Pointer(Result);
if NewLen = OldLen then
begin
ALStringReplaceMoveEx(PSrc^, PRes^, SrcLen);
Inc(PRes, Found);
ALStringReplaceMoveEx(Pointer(NewPattern)^, PRes^, NewLen);
end
else
begin
ALStringReplaceMoveEx(PSrc^, PRes^, Found);
Inc(PRes, Found);
Inc(PSrc, Found + OldLen);
ALStringReplaceMoveEx(Pointer(NewPattern)^, PRes^, NewLen);
Inc(PRes, NewLen);
ALStringReplaceMoveEx(PSrc^, PRes^, SrcLen - Found - OldLen);
end;
end
else {No Matches Found}
Result := S;
end;
end;
end;
////////////////////////////////////////////////////////////////
//////////ALUpperCase from FastCode Aleksandr Sharahov//////////
////////////////////////////////////////////////////////////////
{********************************************}
function AlUpperCase(const s: String): String;
asm
push ebx
push esi
push edi
mov esi, eax // s
mov eax, edx
test esi, esi
jz @nil
mov ebx, [esi-4] // Length(s)
mov edx, ebx
mov edi, eax // @Result
add ebx, -1
jl @nil
and ebx, -4
call System.@LStrSetLength
mov eax, [ebx+esi]
mov edi, [edi] // Result
@loop: mov ecx, eax
or eax, $80808080 // $E1..$FA
mov edx, eax
sub eax, $7B7B7B7B // $66..$7F
xor edx, ecx // $80
or eax, $80808080 // $E6..$FF
sub eax, $66666666 // $80..$99
and eax, edx // $80
shr eax, 2 // $20
xor eax, ecx // Upper
mov[ebx+edi], eax
mov eax, [ebx+esi-4]
sub ebx, 4
jge @loop
pop edi
pop esi
pop ebx
ret
@nil: pop edi
pop esi
pop ebx
jmp System.@LStrClr // Result:=''
end;
{********************************************}
function ALLowerCase(const s: String): String;
asm
push ebx
push esi
push edi
mov esi, eax // s
mov eax, edx
test esi, esi
jz @nil
mov ebx, [esi-4] // Length(s)
mov edx, ebx
mov edi, eax // @Result
add ebx, -1
jl @nil
and ebx, -4
call System.@LStrSetLength
mov eax, [ebx+esi]
mov edi, [edi] // Result
@loop: mov ecx, eax
or eax, $80808080 // $C1..$DA
mov edx, eax
sub eax, $5B5B5B5B // $66..$7F
xor edx, ecx // $80
or eax, $80808080 // $E6..$FF
sub eax, $66666666 // $80..$99
and eax, edx // $80
shr eax, 2 // $20
xor eax, ecx // Lower
mov[ebx+edi], eax
mov eax, [ebx+esi-4]
sub ebx, 4
jge @loop
pop edi
pop esi
pop ebx
ret
@nil: pop edi
pop esi
pop ebx
jmp System.@LStrClr // Result:=''
end;
///////////////////////////
//////////Alcinoe//////////
///////////////////////////
{********************************************************************************}
function ALCopyStr(const aSourceString: String; aStart, aLength: Integer): String;
var
SourceStringLength: Integer;
begin
SourceStringLength := Length(aSourceString);
if (aStart < 1) then
aStart := 1;
if (SourceStringLength = 0) or
(aLength < 1) or
(aStart > SourceStringLength) then
begin
Result := '';
Exit;
end;
if aLength > SourceStringLength - (aStart - 1) then
aLength := SourceStringLength - (aStart - 1);
SetLength(Result, aLength);
ALMove(aSourceString[aStart], Result[1], aLength);
end;
{************}
var
Ch: char;
//***********************************************************************
function AlSMTPClientParseEmail(FriendlyEmail: String; var FriendlyName: String): String;
var
I, J: Integer;
Flag: Boolean;
Delim: char;
begin
Result := '';
FriendlyName := '';
Flag := (ALCharPos('<', FriendlyEmail) > 0);
{ Skip spaces }
I := 1;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] = ' ') do
Inc(I);
if I > Length(FriendlyEmail) then
Exit;
{ Check if quoted string }
if FriendlyEmail[I] in ['"', ''''] then
begin
Delim := FriendlyEmail[I];
{ Skip opening quote }
Inc(I);
{ Go to closing quote }
J := I;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> Delim) do
Inc(I);
FriendlyName := AlCopyStr(FriendlyEmail, J, I - J);
Inc(I);
if Flag then
begin
{ Go to less-than sign }
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> '<') do
Inc(I);
Inc(I);
J := I;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> '>') do
Inc(I);
Result := AlCopyStr(FriendlyEmail, J, I - J);
end
else
Result := Trim(AlCopyStr(FriendlyEmail, I, Length(FriendlyEmail)));
end
else if Flag then
begin
{ Go to less-than sign }
J := I;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> '<') do
Inc(I);
FriendlyName := Trim(AlCopyStr(FriendlyEmail, J, I - J));
Inc(I);
{ Go to greater-than sign }
J := I;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> '>') do
Inc(I);
Result := AlCopyStr(FriendlyEmail, J, I - J);
end
else
begin
{ No <..>, goto next space }
J := I;
while (I <= Length(FriendlyEmail)) and (FriendlyEmail[I] <> ' ') do
Inc(I);
FriendlyName := Trim(AlCopyStr(FriendlyEmail, J, I - J));
Result := Trim(AlCopyStr(FriendlyEmail, I + 1, Length(FriendlyEmail)));
end;
if (Result = '') and (AlCharPos('@', FriendlyName) > 0) then
begin
Result := FriendlyName;
FriendlyName := '';
end;
end;
{*********************************************}
function AlSMTPClientGenerateMessageID: String;
begin
Result := AlStringReplace(ALMakeKeyStrByGUID, '-', '', [rfReplaceAll]) + '@' + AlGetLocalHostName;
end;
{***********************************}
{Perform Forward Move of 0..36 Bytes}
{On Entry, ECX = Count, EAX = Source+Count, EDX = Dest+Count. Destroys ECX}
procedure ALSmallForwardMove;
asm
jmp dword ptr [@@FwdJumpTable+ecx*4]
nop {Align Jump Table}
@@FwdJumpTable:
dd @@Done {Removes need to test for zero size move}
dd @@Fwd01, @@Fwd02, @@Fwd03, @@Fwd04, @@Fwd05, @@Fwd06, @@Fwd07, @@Fwd08
dd @@Fwd09, @@Fwd10, @@Fwd11, @@Fwd12, @@Fwd13, @@Fwd14, @@Fwd15, @@Fwd16
dd @@Fwd17, @@Fwd18, @@Fwd19, @@Fwd20, @@Fwd21, @@Fwd22, @@Fwd23, @@Fwd24
dd @@Fwd25, @@Fwd26, @@Fwd27, @@Fwd28, @@Fwd29, @@Fwd30, @@Fwd31, @@Fwd32
dd @@Fwd33, @@Fwd34, @@Fwd35, @@Fwd36
@@Fwd36:
mov ecx, [eax-36]
mov[edx-36], ecx
@@Fwd32:
mov ecx, [eax-32]
mov[edx-32], ecx
@@Fwd28:
mov ecx, [eax-28]
mov[edx-28], ecx
@@Fwd24:
mov ecx, [eax-24]
mov[edx-24], ecx
@@Fwd20:
mov ecx, [eax-20]
mov[edx-20], ecx
@@Fwd16:
mov ecx, [eax-16]
mov[edx-16], ecx
@@Fwd12:
mov ecx, [eax-12]
mov[edx-12], ecx
@@Fwd08:
mov ecx, [eax-8]
mov[edx-8], ecx
@@Fwd04:
mov ecx, [eax-4]
mov[edx-4], ecx
ret
nop
@@Fwd35:
mov ecx, [eax-35]
mov[edx-35], ecx
@@Fwd31:
mov ecx, [eax-31]
mov[edx-31], ecx
@@Fwd27:
mov ecx, [eax-27]
mov[edx-27], ecx
@@Fwd23:
mov ecx, [eax-23]
mov[edx-23], ecx
@@Fwd19:
mov ecx, [eax-19]
mov[edx-19], ecx
@@Fwd15:
mov ecx, [eax-15]
mov[edx-15], ecx
@@Fwd11:
mov ecx, [eax-11]
mov[edx-11], ecx
@@Fwd07:
mov ecx, [eax-7]
mov[edx-7], ecx
mov ecx, [eax-4]
mov[edx-4], ecx
ret
nop
@@Fwd03:
movzx ecx, word ptr [eax-3]
mov[edx-3], cx
movzx ecx, byte ptr [eax-1]
mov[edx-1], cl
ret
@@Fwd34:
mov ecx, [eax-34]
mov[edx-34], ecx
@@Fwd30:
mov ecx, [eax-30]
mov[edx-30], ecx
@@Fwd26:
mov ecx, [eax-26]
mov[edx-26], ecx
@@Fwd22:
mov ecx, [eax-22]
mov[edx-22], ecx
@@Fwd18:
mov ecx, [eax-18]
mov[edx-18], ecx
@@Fwd14:
mov ecx, [eax-14]
mov[edx-14], ecx
@@Fwd10:
mov ecx, [eax-10]
mov[edx-10], ecx
@@Fwd06:
mov ecx, [eax-6]
mov[edx-6], ecx
@@Fwd02:
movzx ecx, word ptr [eax-2]
mov[edx-2], cx
ret
nop
nop
nop
@@Fwd33:
mov ecx, [eax-33]
mov[edx-33], ecx
@@Fwd29:
mov ecx, [eax-29]
mov[edx-29], ecx
@@Fwd25:
mov ecx, [eax-25]
mov[edx-25], ecx
@@Fwd21:
mov ecx, [eax-21]
mov[edx-21], ecx
@@Fwd17:
mov ecx, [eax-17]
mov[edx-17], ecx
@@Fwd13:
mov ecx, [eax-13]
mov[edx-13], ecx
@@Fwd09:
mov ecx, [eax-9]
mov[edx-9], ecx
@@Fwd05:
mov ecx, [eax-5]
mov[edx-5], ecx
@@Fwd01:
movzx ecx, byte ptr [eax-1]
mov[edx-1], cl
ret
@@Done:
end;
{************************************}
{Perform Backward Move of 0..36 Bytes}
{On Entry, ECX = Count, EAX = Source, EDX = Dest. Destroys ECX}
procedure ALSmallBackwardMove;
asm
jmp dword ptr [@@BwdJumpTable+ecx*4]
nop {Align Jump Table}
@@BwdJumpTable:
dd @@Done {Removes need to test for zero size move}
dd @@Bwd01, @@Bwd02, @@Bwd03, @@Bwd04, @@Bwd05, @@Bwd06, @@Bwd07, @@Bwd08
dd @@Bwd09, @@Bwd10, @@Bwd11, @@Bwd12, @@Bwd13, @@Bwd14, @@Bwd15, @@Bwd16
dd @@Bwd17, @@Bwd18, @@Bwd19, @@Bwd20, @@Bwd21, @@Bwd22, @@Bwd23, @@Bwd24
dd @@Bwd25, @@Bwd26, @@Bwd27, @@Bwd28, @@Bwd29, @@Bwd30, @@Bwd31, @@Bwd32
dd @@Bwd33, @@Bwd34, @@Bwd35, @@Bwd36
@@Bwd36:
mov ecx, [eax+32]
mov[edx+32], ecx
@@Bwd32:
mov ecx, [eax+28]
mov[edx+28], ecx
@@Bwd28:
mov ecx, [eax+24]
mov[edx+24], ecx
@@Bwd24:
mov ecx, [eax+20]
mov[edx+20], ecx
@@Bwd20:
mov ecx, [eax+16]
mov[edx+16], ecx
@@Bwd16:
mov ecx, [eax+12]
mov[edx+12], ecx
@@Bwd12:
mov ecx, [eax+8]
mov[edx+8], ecx
@@Bwd08:
mov ecx, [eax+4]
mov[edx+4], ecx
@@Bwd04:
mov ecx, [eax]
mov[edx], ecx
ret
nop
nop
nop
@@Bwd35:
mov ecx, [eax+31]
mov[edx+31], ecx
@@Bwd31:
mov ecx, [eax+27]
mov[edx+27], ecx
@@Bwd27:
mov ecx, [eax+23]
mov[edx+23], ecx
@@Bwd23:
mov ecx, [eax+19]
mov[edx+19], ecx
@@Bwd19:
mov ecx, [eax+15]
mov[edx+15], ecx
@@Bwd15:
mov ecx, [eax+11]
mov[edx+11], ecx
@@Bwd11:
mov ecx, [eax+7]
mov[edx+7], ecx
@@Bwd07:
mov ecx, [eax+3]
mov[edx+3], ecx
mov ecx, [eax]
mov[edx], ecx
ret
nop
nop
nop
@@Bwd03:
movzx ecx, word ptr [eax+1]
mov[edx+1], cx
movzx ecx, byte ptr [eax]
mov[edx], cl
ret
nop
nop
@@Bwd34:
mov ecx, [eax+30]
mov[edx+30], ecx
@@Bwd30:
mov ecx, [eax+26]
mov[edx+26], ecx
@@Bwd26:
mov ecx, [eax+22]
mov[edx+22], ecx
@@Bwd22:
mov ecx, [eax+18]
mov[edx+18], ecx
@@Bwd18:
mov ecx, [eax+14]
mov[edx+14], ecx
@@Bwd14:
mov ecx, [eax+10]
mov[edx+10], ecx
@@Bwd10:
mov ecx, [eax+6]
mov[edx+6], ecx
@@Bwd06:
mov ecx, [eax+2]
mov[edx+2], ecx
@@Bwd02:
movzx ecx, word ptr [eax]
mov[edx], cx
ret
nop
@@Bwd33:
mov ecx, [eax+29]
mov[edx+29], ecx
@@Bwd29:
mov ecx, [eax+25]
mov[edx+25], ecx
@@Bwd25:
mov ecx, [eax+21]
mov[edx+21], ecx
@@Bwd21:
mov ecx, [eax+17]
mov[edx+17], ecx
@@Bwd17:
mov ecx, [eax+13]
mov[edx+13], ecx
@@Bwd13:
mov ecx, [eax+9]
mov[edx+9], ecx
@@Bwd09:
mov ecx, [eax+5]
mov[edx+5], ecx
@@Bwd05:
mov ecx, [eax+1]
mov[edx+1], ecx
@@Bwd01:
movzx ecx, byte ptr[eax]
mov[edx], cl
ret
nop
nop
@@Done:
end;
var
VALMove_PrefetchLimit: Integer;
{***********************************************************}
{Dest MUST be 16-Byes Aligned, Count MUST be multiple of 16 }
procedure ALAlignedFwdMoveSSE(const Source; var Dest; Count: Integer);
const
Prefetch = 512;
asm
push ebx
mov ebx, eax {ebx = Source}
mov eax, ecx {EAX = Count}
and eax, -128 {EAX = No of Bytes to Block Move}
add ebx, eax
add edx, eax
shr eax, 3 {EAX = No of QWORD's to Block Move}
neg eax
cmp eax, VALMove_PrefetchLimit {Count > Limit - Use Prefetch}
jl @Large
@Small:
test ebx, 15 {Check if Both Source/Dest are Aligned}
jnz @SmallUnaligned
@SmallAligned: {Both Source and Dest 16-Byte Aligned}
nop {Align Loops}
nop
nop
@SmallAlignedLoop:
movaps xmm0, [ebx+8*eax]
movaps xmm1, [ebx+8*eax+16]
movaps xmm2, [ebx+8*eax+32]
movaps xmm3, [ebx+8*eax+48]
movaps[edx+8*eax], xmm0
movaps[edx+8*eax+16], xmm1
movaps[edx+8*eax+32], xmm2
movaps[edx+8*eax+48], xmm3
movaps xmm4, [ebx+8*eax+64]
movaps xmm5, [ebx+8*eax+80]
movaps xmm6, [ebx+8*eax+96]
movaps xmm7, [ebx+8*eax+112]
movaps[edx+8*eax+64], xmm4
movaps[edx+8*eax+80], xmm5
movaps[edx+8*eax+96], xmm6
movaps[edx+8*eax+112], xmm7
add eax, 16
js @SmallAlignedLoop
jmp @Remainder
@SmallUnaligned: {Source Not 16-Byte Aligned}
@SmallUnalignedLoop:
movups xmm0, [ebx+8*eax]
movups xmm1, [ebx+8*eax+16]
movups xmm2, [ebx+8*eax+32]
movups xmm3, [ebx+8*eax+48]
movaps[edx+8*eax], xmm0
movaps[edx+8*eax+16], xmm1
movaps[edx+8*eax+32], xmm2
movaps[edx+8*eax+48], xmm3
movups xmm4, [ebx+8*eax+64]
movups xmm5, [ebx+8*eax+80]
movups xmm6, [ebx+8*eax+96]
movups xmm7, [ebx+8*eax+112]
movaps[edx+8*eax+64], xmm4
movaps[edx+8*eax+80], xmm5
movaps[edx+8*eax+96], xmm6
movaps[edx+8*eax+112], xmm7
add eax, 16
js @SmallUnalignedLoop
jmp @Remainder
@Large:
test ebx, 15 {Check if Both Source/Dest Aligned}
jnz @LargeUnaligned
@LargeAligned: {Both Source and Dest 16-Byte Aligned}
@LargeAlignedLoop:
prefetchnta[ebx+8*eax+Prefetch]
prefetchnta[ebx+8*eax+Prefetch+64]
movaps xmm0, [ebx+8*eax]
movaps xmm1, [ebx+8*eax+16]
movaps xmm2, [ebx+8*eax+32]
movaps xmm3, [ebx+8*eax+48]
movntps[edx+8*eax], xmm0
movntps[edx+8*eax+16], xmm1
movntps[edx+8*eax+32], xmm2
movntps[edx+8*eax+48], xmm3
movaps xmm4, [ebx+8*eax+64]
movaps xmm5, [ebx+8*eax+80]
movaps xmm6, [ebx+8*eax+96]
movaps xmm7, [ebx+8*eax+112]
movntps[edx+8*eax+64], xmm4
movntps[edx+8*eax+80], xmm5
movntps[edx+8*eax+96], xmm6
movntps[edx+8*eax+112], xmm7
add eax, 16
js @LargeAlignedLoop
sfence
jmp @Remainder
@LargeUnaligned: {Source Not 16-Byte Aligned}
@LargeUnalignedLoop:
prefetchnta[ebx+8*eax+Prefetch]
prefetchnta[ebx+8*eax+Prefetch+64]
movups xmm0, [ebx+8*eax]
movups xmm1, [ebx+8*eax+16]
movups xmm2, [ebx+8*eax+32]
movups xmm3, [ebx+8*eax+48]
movntps[edx+8*eax], xmm0
movntps[edx+8*eax+16], xmm1
movntps[edx+8*eax+32], xmm2
movntps[edx+8*eax+48], xmm3
movups xmm4, [ebx+8*eax+64]
movups xmm5, [ebx+8*eax+80]
movups xmm6, [ebx+8*eax+96]
movups xmm7, [ebx+8*eax+112]
movntps[edx+8*eax+64], xmm4
movntps[edx+8*eax+80], xmm5
movntps[edx+8*eax+96], xmm6
movntps[edx+8*eax+112], xmm7
add eax, 16
js @LargeUnalignedLoop
sfence
@Remainder:
and ecx, $7F {ECX = Remainder (0..112 - Multiple of 16)}
jz @Done
add ebx, ecx
add edx, ecx
neg ecx
@RemainderLoop:
movups xmm0, [ebx+ecx]
movaps[edx+ecx], xmm0
add ecx, 16
jnz @RemainderLoop
@Done:
pop ebx
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX > EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALForwards_SSE;
const
LARGESIZE = 2048;
asm
cmp ecx, LARGESIZE
jge @FwdLargeMove
cmp ecx, CALMOVE_SMALLMOVESIZE+32
movups xmm0, [eax]
jg @FwdMoveSSE
movups xmm1, [eax+16]
movups[edx], xmm0
movups[edx+16], xmm1
add eax, ecx
add edx, ecx
sub ecx, 32
jmp ALSmallForwardMove
@FwdMoveSSE:
push ebx
mov ebx, edx
{Align Writes}
add eax, ecx
add ecx, edx
add edx, 15
and edx, -16
sub ecx, edx
add edx, ecx
{Now Aligned}
sub ecx, 32
neg ecx
@FwdLoopSSE:
movups xmm1, [eax+ecx-32]
movups xmm2, [eax+ecx-16]
movaps[edx+ecx-32], xmm1
movaps[edx+ecx-16], xmm2
add ecx, 32
jle @FwdLoopSSE
movups[ebx], xmm0 {First 16 Bytes}
neg ecx
add ecx, 32
pop ebx
jmp ALSmallForwardMove
@FwdLargeMove:
push ebx
mov ebx, ecx
test edx, 15
jz @FwdLargeAligned
{16 byte Align Destination}
mov ecx, edx
add ecx, 15
and ecx, -16
sub ecx, edx
add eax, ecx
add edx, ecx
sub ebx, ecx
{Destination now 16 Byte Aligned}
call ALSmallForwardMove
mov ecx, ebx
@FwdLargeAligned:
and ecx, -16
sub ebx, ecx {EBX = Remainder}
push edx
push eax
push ecx
call ALAlignedFwdMoveSSE
pop ecx
pop eax
pop edx
add ecx, ebx
add eax, ecx
add edx, ecx
mov ecx, ebx
pop ebx
jmp ALSmallForwardMove
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX < EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALBackwards_SSE;
asm
cmp ecx, CALMOVE_SMALLMOVESIZE+32
jg @BwdMoveSSE
sub ecx, 32
movups xmm1, [eax+ecx]
movups xmm2, [eax+ecx+16]
movups[edx+ecx], xmm1
movups[edx+ecx+16], xmm2
jmp ALSmallBackwardMove
@BwdMoveSSE:
push ebx
movups xmm0, [eax+ecx-16] {Last 16 Bytes}
{Align Writes}
lea ebx, [edx+ecx]
and ebx, 15
sub ecx, ebx
add ebx, ecx
{Now Aligned}
sub ecx, 32
@BwdLoop:
movups xmm1, [eax+ecx]
movups xmm2, [eax+ecx+16]
movaps[edx+ecx], xmm1
movaps[edx+ecx+16], xmm2
sub ecx, 32
jge @BwdLoop
movups[edx+ebx-16], xmm0 {Last 16 Bytes}
add ecx, 32
pop ebx
jmp ALSmallBackwardMove
end;
{******************************}
{Move using SSE Instruction Set}
procedure ALMove_SSE(const Source; var Dest; Count: Integer);
asm
cmp ecx, CALMOVE_SMALLMOVESIZE
ja @Large {Count > SMALLMOVESIZE or Count < 0}
cmp eax, edx
jbe @SmallCheck
add eax, ecx
add edx, ecx
jmp ALSmallForwardMove
@SmallCheck:
jne ALSmallBackwardMove
ret {For Compatibility with Delphi's move for Source = Dest}
@Large:
jng @Done {For Compatibility with Delphi's move for Count < 0}
cmp eax, edx
ja ALForwards_SSE
je @Done {For Compatibility with Delphi's move for Source = Dest}
sub edx, ecx
cmp eax, edx
lea edx, [edx+ecx]
jna ALForwards_SSE
jmp ALBackwards_SSE {Source/Dest Overlap}
@Done:
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX > EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALForwards_IA32;
asm
push ebx
mov ebx, edx
fild qword ptr [eax]
add eax, ecx {QWORD Align Writes}
add ecx, edx
add edx, 7
and edx, -8
sub ecx, edx
add edx, ecx {Now QWORD Aligned}
sub ecx, 16
neg ecx
@FwdLoop:
fild qword ptr [eax+ecx-16]
fistp qword ptr [edx+ecx-16]
fild qword ptr [eax+ecx-8]
fistp qword ptr [edx+ecx-8]
add ecx, 16
jle @FwdLoop
fistp qword ptr [ebx]
neg ecx
add ecx, 16
pop ebx
jmp ALSmallForwardMove
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX > EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALForwards_MMX;
const
LARGESIZE = 1024;
asm
cmp ecx, LARGESIZE
jge @FwdLargeMove
cmp ecx, 72 {Size at which using MMX becomes worthwhile}
jl ALForwards_IA32
push ebx
mov ebx, edx
movq mm0, [eax] {First 8 Bytes}
{QWORD Align Writes}
add eax, ecx
add ecx, edx
add edx, 7
and edx, -8
sub ecx, edx
add edx, ecx
{Now QWORD Aligned}
sub ecx, 32
neg ecx
@FwdLoopMMX:
movq mm1, [eax+ecx-32]
movq mm2, [eax+ecx-24]
movq mm3, [eax+ecx-16]
movq mm4, [eax+ecx- 8]
movq[edx+ecx-32], mm1
movq[edx+ecx-24], mm2
movq[edx+ecx-16], mm3
movq[edx+ecx- 8], mm4
add ecx, 32
jle @FwdLoopMMX
movq[ebx], mm0 {First 8 Bytes}
emms
pop ebx
neg ecx
add ecx, 32
jmp ALSmallForwardMove
@FwdLargeMove:
push ebx
mov ebx, ecx
test edx, 15
jz @FwdAligned
{16 byte Align Destination}
mov ecx, edx
add ecx, 15
and ecx, -16
sub ecx, edx
add eax, ecx
add edx, ecx
sub ebx, ecx
{Destination now 16 Byte Aligned}
call ALSmallForwardMove
@FwdAligned:
mov ecx, ebx
and ecx, -16
sub ebx, ecx {EBX = Remainder}
push esi
push edi
mov esi, eax {ESI = Source}
mov edi, edx {EDI = Dest}
mov eax, ecx {EAX = Count}
and eax, -64 {EAX = No of Bytes to Blocks Moves}
and ecx, $3F {ECX = Remaining Bytes to Move (0..63)}
add esi, eax
add edi, eax
shr eax, 3 {EAX = No of QWORD's to Block Move}
neg eax
@MMXcopyloop:
movq mm0, [esi+eax*8 ]
movq mm1, [esi+eax*8+ 8]
movq mm2, [esi+eax*8+16]
movq mm3, [esi+eax*8+24]
movq mm4, [esi+eax*8+32]
movq mm5, [esi+eax*8+40]
movq mm6, [esi+eax*8+48]
movq mm7, [esi+eax*8+56]
movq[edi+eax*8 ], mm0
movq[edi+eax*8+ 8], mm1
movq[edi+eax*8+16], mm2
movq[edi+eax*8+24], mm3
movq[edi+eax*8+32], mm4
movq[edi+eax*8+40], mm5
movq[edi+eax*8+48], mm6
movq[edi+eax*8+56], mm7
add eax, 8
jnz @MMXcopyloop
emms {Empty MMX State}
add ecx, ebx
shr ecx, 2
rep movsd
mov ecx, ebx
and ecx, 3
rep movsb
pop edi
pop esi
pop ebx
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX < EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALBackwards_IA32;
asm
push ebx
fild qword ptr [eax+ecx-8]
lea ebx, [edx+ecx] {QWORD Align Writes}
and ebx, 7
sub ecx, ebx
add ebx, ecx {Now QWORD Aligned, EBX = Original Length}
sub ecx, 16
@BwdLoop:
fild qword ptr [eax+ecx]
fild qword ptr [eax+ecx+8]
fistp qword ptr [edx+ecx+8]
fistp qword ptr [edx+ecx]
sub ecx, 16
jge @BwdLoop
fistp qword ptr [edx+ebx-8]
add ecx, 16
pop ebx
jmp ALSmallBackwardMove
end;
{****************************************************************************}
{Move ECX Bytes from EAX to EDX, where EAX < EDX and ECX > 36 (SMALLMOVESIZE)}
procedure ALBackwards_MMX;
asm
cmp ecx, 72 {Size at which using MMX becomes worthwhile}
jl ALBackwards_IA32
push ebx
movq mm0, [eax+ecx-8] {Get Last QWORD}
{QWORD Align Writes}
lea ebx, [edx+ecx]
and ebx, 7
sub ecx, ebx
add ebx, ecx
{Now QWORD Aligned}
sub ecx, 32
@BwdLoopMMX:
movq mm1, [eax+ecx ]
movq mm2, [eax+ecx+ 8]
movq mm3, [eax+ecx+16]
movq mm4, [eax+ecx+24]
movq[edx+ecx+24], mm4
movq[edx+ecx+16], mm3
movq[edx+ecx+ 8], mm2
movq[edx+ecx ], mm1
sub ecx, 32
jge @BwdLoopMMX
movq[edx+ebx-8], mm0 {Last QWORD}
emms
add ecx, 32
pop ebx
jmp ALSmallBackwardMove
end;
{******************************}
{Move using MMX Instruction Set}
procedure ALMove_MMX(const Source; var Dest; Count: Integer);
asm
cmp ecx, CALMOVE_SMALLMOVESIZE
ja @Large {Count > SMALLMOVESIZE or Count < 0}
cmp eax, edx
jbe @SmallCheck
add eax, ecx
add edx, ecx
jmp ALSmallForwardMove
@SmallCheck:
jne ALSmallBackwardMove
ret {For Compatibility with Delphi's move for Source = Dest}
@Large:
jng @Done {For Compatibility with Delphi's move for Count < 0}
cmp eax, edx
ja ALForwards_MMX
je @Done {For Compatibility with Delphi's move for Source = Dest}
sub edx, ecx
cmp eax, edx
lea edx, [edx+ecx]
jna ALForwards_MMX
jmp ALBackwards_MMX {Source/Dest Overlap}
@Done:
end;
procedure ALMove_IA32(const Source; var Dest; Count: Integer);
asm
cmp ecx, CALMOVE_SMALLMOVESIZE
ja @Large {Count > SMALLMOVESIZE or Count < 0}
cmp eax, edx
jbe @SmallCheck
add eax, ecx
add edx, ecx
jmp ALSmallForwardMove
@SmallCheck:
jne ALSmallBackwardMove
ret {For Compatibility with Delphi's move for Source = Dest}
@Large:
jng @Done {For Compatibility with Delphi's move for Count < 0}
cmp eax, edx
ja ALForwards_IA32
je @Done {For Compatibility with Delphi's move for Source = Dest}
sub edx, ecx
cmp eax, edx
lea edx, [edx+ecx]
jna ALForwards_IA32
jmp ALBackwards_IA32 {Source/Dest Overlap}
@Done:
end;
//***************************************************************************
//**** ALCPUID Partial Unit
//***************************************************************************
var
VALCPUInfo: TALCPUinfo;
function ALGetCPUInfo: TALCPUinfo;
begin
Result := VALCPUInfo;
end;
function ALPos_IA32(const SubStr: ansistring; const Str: ansistring): Integer;
asm
test eax, eax
jz @NotFoundExit {Exit if SubStr = ''}
test edx, edx
jz @NotFound {Exit if Str = ''}
mov ecx, [edx-4] {Length(Str)}
cmp[eax-4], 1 {Length SubStr = 1?}
je @SingleChar {Yes - Exit via CharPos}
jl @NotFound {Exit if Length(SubStr) < 1}
sub ecx, [eax-4] {Subtract Length(SubStr), -ve handled by
CharPos}
add ecx, 1 {Number of Chars to Check for 1st Char}
push esi {Save Registers}
push edi
push ebx
push ebp
mov ebx, [eax] {BL = 1st Char of SubStr}
mov esi, eax {Start Address of SubStr}
mov edi, ecx {Initial Remainder Count}
mov ebp, edx {Start Address of Str}
@StrLoop:
mov eax, ebx {AL = 1st char of SubStr for next Search}
mov ecx, edi {Remaining Length}
push edx {Save Start Position}
call @CharPos {Search for 1st Character}
pop edx {Restore Start Position}
jz @StrExit {Exit with Zero Result if 1st Char Not Found}
mov ecx, [esi-4] {Length SubStr}
add edx, eax {Update Start Position for Next Loop}
sub edi, eax {Update Remaining Length for Next Loop}
sub ecx, 1 {Remaining Characters to Compare}
@StrCheck:
mov al, [edx+ecx-1] {Compare Next Char of SubStr and Str}
cmp al, [esi+ecx]
jne @StrLoop {Different - Return to First Character Search}
sub ecx, 1
jg @StrCheck {Check each Remaining Character}
mov eax, edx {All Characters Matched - Calculate Result}
sub eax, ebp
@StrExit:
pop ebp {Restore Registers}
pop ebx
pop edi
pop esi
ret
@NotFound:
xor eax, eax {Return 0}
@NotFoundExit:
ret
@SingleChar:
mov al, [eax] {Search Character}
{Return Position of Character AL within a String of Length ECX starting}
{at Address EDX. If Found, Return Index in EAX and Clear Zero Flag, }
{otherwise Return 0 in EAX and Set Zero Flag. Changes EAX, ECX and EDX}
@CharPos:
push ecx {Save Length}
neg ecx
cmp ecx, -4
jle @NotSmall {Length >= 4}
or ecx, ecx
jge @CharNotFound {Exit if Length <= 0}
cmp al, [edx] {Check 1st Char}
je @Found
add ecx, 1
jz @CharNotFound
cmp al, [edx+1] {Check 2nd Char}
je @Found
add ecx, 1
jz @CharNotFound
cmp al, [edx+2] {Check 3rd Char}
je @Found
jmp @CharNotFound
@NotSmall:
sub edx, ecx {End of String}
@Loop:
cmp al, [edx+ecx] {Compare Next 4 Characters}
je @Found
cmp al, [edx+ecx+1]
je @Found2
cmp al, [edx+ecx+2]
je @Found3
cmp al, [edx+ecx+3]
je @Found4
add ecx, 4 {Next Character Position}
and ecx, -4 {Prevent Read Past Last Character}
jnz @Loop {Loop until all Characters Compared}
@CharNotFound:
pop ecx {Restore Stack}
xor eax, eax {Set Result to 0 and Set Zero Flag}
ret {Finished}
@Found4:
add ecx, 1
@Found3:
add ecx, 1
@Found2:
add ecx, 1
@Found:
add ecx, 1
pop eax
add eax, ecx {Set Result and Clear Zero Flag}
end;
{***************************************************************************}
function ALPos_MMX(const SubStr: ansistring; const Str: ansistring): Integer;
asm
test eax, eax
jz @NotFoundExit {Exit if SurStr = ''}
test edx, edx
jz @NotFound {Exit if Str = ''}
mov ecx, [edx-4] {Length(Str)}
cmp[eax-4], 1 {Length SubStr = 1?}
je @SingleChar {Yes - Exit via CharPos}
jl @NotFound {Exit if Length(SubStr) < 1}
sub ecx, [eax-4] {Subtract Length(SubStr), -ve handled by
CharPos}
add ecx, 1 {Number of Chars to Check for 1st Char}
push esi {Save Registers}
push edi
push ebx
push ebp
mov esi, eax {Start Address of SubStr}
mov edi, ecx {Initial Remainder Count}
mov eax, [eax] {AL = 1st Char of SubStr}
mov ebp, edx {Start Address of Str}
mov ebx, eax {Maintain 1st Search Char in BL}
@StrLoop:
mov eax, ebx {AL = 1st char of SubStr}
mov ecx, edi {Remaining Length}
push edx {Save Start Position}
call @CharPos {Search for 1st Character}
pop edx {Restore Start Position}
test eax, eax {Result = 0?}
jz @StrExit {Exit if 1st Character Not Found}
mov ecx, [esi-4] {Length SubStr}
add edx, eax {Update Start Position for Next Loop}
sub edi, eax {Update Remaining Length for Next Loop}
sub ecx, 1 {Remaining Characters to Compare}
@StrCheck:
mov al, [edx+ecx-1] {Compare Next Char of SubStr and Str}
cmp al, [esi+ecx]
jne @StrLoop {Different - Return to First Character Search}
sub ecx, 1
jnz @StrCheck {Check each Remaining Character}
mov eax, edx {All Characters Matched - Calculate Result}
sub eax, ebp
@StrExit:
pop ebp {Restore Registers}
pop ebx
pop edi
pop esi
ret
@NotFound:
xor eax, eax {Return 0}
@NotFoundExit:
ret
@SingleChar:
mov al, [eax] {Search Character}
@CharPos:
CMP ECX, 8
JG @@NotSmall
@@Small:
or ecx, ecx
jle @@NotFound {Exit if Length <= 0}
CMP AL, [EDX]
JZ @Found1
DEC ECX
JZ @@NotFound
CMP AL, [EDX+1]
JZ @Found2
DEC ECX
JZ @@NotFound
CMP AL, [EDX+2]
JZ @Found3
DEC ECX
JZ @@NotFound
CMP AL, [EDX+3]
JZ @Found4
DEC ECX
JZ @@NotFound
CMP AL, [EDX+4]
JZ @Found5
DEC ECX
JZ @@NotFound
CMP AL, [EDX+5]
JZ @Found6
DEC ECX
JZ @@NotFound
CMP AL, [EDX+6]
JZ @Found7
DEC ECX
JZ @@NotFound
CMP AL, [EDX+7]
JZ @Found8
@@NotFound:
xor EAX, EAX
RET
@Found1:
MOV EAX, 1
RET
@Found2:
MOV EAX, 2
RET
@Found3:
MOV EAX, 3
RET
@Found4:
MOV EAX, 4
RET
@Found5:
MOV EAX, 5
RET
@Found6:
MOV EAX, 6
RET
@Found7:
MOV EAX, 7
RET
@Found8:
MOV EAX, 8
RET
@@NotSmall: {Length(Str) > 8}
MOV AH, AL
ADD EDX, ECX
MOVD MM0, EAX
PUNPCKLWD MM0, MM0
PUNPCKLDQ MM0, MM0
PUSH ECX {Save Length}
NEG ECX
@@First8:
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare All 8 Bytes}
PACKSSWB MM1, MM1 {Pack Result into 4 Bytes}
MOVD EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
JGE @@Last8
@@Align: {Align to Previous 8 Byte Boundary}
LEA EAX, [EDX+ECX]
and EAX, 7 {EAX -> 0 or 4}
SUB ECX, EAX
@@Loop:
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare All 8 Bytes}
PACKSSWB MM1, MM1 {Pack Result into 4 Bytes}
MOVD EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
{$IFNDEF NoUnroll}
JGE @@Last8
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare All 8 Bytes}
PACKSSWB MM1, MM1 {Pack Result into 4 Bytes}
MOVD EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
{$ENDIF}
JL @@Loop
@@Last8:
MOVQ MM1, [EDX-8] {Position for Last 8 Used Characters}
POP EDX {Original Length}
PCMPEQB MM1, MM0 {Compare All 8 Bytes}
PACKSSWB MM1, MM1 {Pack Result into 4 Bytes}
MOVD EAX, MM1
TEST EAX, EAX
JNZ @@Matched2 {Exit on Match at any Position}
EMMS
RET {Finished - Not Found}
@@Matched: {Set Result from 1st Match in EDX}
POP EDX {Original Length}
ADD EDX, ECX
@@Matched2:
EMMS
SUB EDX, 8 {Adjust for Extra ADD ECX,8 in Loop}
TEST AL, AL
JNZ @@MatchDone {Match at Position 1 or 2}
TEST AH, AH
JNZ @@Match1 {Match at Position 3 or 4}
shr EAX, 16
TEST AL, AL
JNZ @@Match2 {Match at Position 5 or 6}
shr EAX, 8
ADD EDX, 6
JMP @@MatchDone
@@Match2:
ADD EDX, 4
JMP @@MatchDone
@@Match1:
shr EAX, 8 {AL <- AH}
ADD EDX, 2
@@MatchDone:
xor EAX, 2
and EAX, 3 {EAX <- 1 or 2}
ADD EAX, EDX
end;
{***************************************************************************}
function ALPos_SSE(const SubStr: ansistring; const Str: ansistring): Integer;
asm
test eax, eax
jz @NotFoundExit {Exit if SurStr = ''}
test edx, edx
jz @NotFound {Exit if Str = ''}
mov ecx, [edx-4] {Length(Str)}
cmp[eax-4], 1 {Length SubStr = 1?}
je @SingleChar {Yes - Exit via CharPos}
jl @NotFound {Exit if Length(SubStr) < 1}
sub ecx, [eax-4] {Subtract Length(SubStr), -ve handled by
CharPos}
add ecx, 1 {Number of Chars to Check for 1st Char}
push esi {Save Registers}
push edi
push ebx
push ebp
mov esi, eax {Start Address of SubStr}
mov edi, ecx {Initial Remainder Count}
mov eax, [eax] {AL = 1st Char of SubStr}
mov ebp, edx {Start Address of Str}
mov ebx, eax {Maintain 1st Search Char in BL}
@StrLoop:
mov eax, ebx {AL = 1st char of SubStr}
mov ecx, edi {Remaining Length}
push edx {Save Start Position}
call @CharPos {Search for 1st Character}
pop edx {Restore Start Position}
test eax, eax {Result = 0?}
jz @StrExit {Exit if 1st Character Not Found}
mov ecx, [esi-4] {Length SubStr}
add edx, eax {Update Start Position for Next Loop}
sub edi, eax {Update Remaining Length for Next Loop}
sub ecx, 1 {Remaining Characters to Compare}
@StrCheck:
mov al, [edx+ecx-1] {Compare Next Char of SubStr and Str}
cmp al, [esi+ecx]
jne @StrLoop {Different - Return to First Character Search}
sub ecx, 1
jnz @StrCheck {Check each Remaining Character}
mov eax, edx {All Characters Matched - Calculate Result}
sub eax, ebp
@StrExit:
pop ebp {Restore Registers}
pop ebx
pop edi
pop esi
ret
@NotFound:
xor eax, eax {Return 0}
@NotFoundExit:
ret
@SingleChar:
mov al, [eax] {Search Character}
@CharPos:
CMP ECX, 8
JG @@NotSmall
@@Small:
or ecx, ecx
jle @@NotFound {Exit if Length <= 0}
CMP AL, [EDX]
JZ @Found1
DEC ECX
JZ @@NotFound
CMP AL, [EDX+1]
JZ @Found2
DEC ECX
JZ @@NotFound
CMP AL, [EDX+2]
JZ @Found3
DEC ECX
JZ @@NotFound
CMP AL, [EDX+3]
JZ @Found4
DEC ECX
JZ @@NotFound
CMP AL, [EDX+4]
JZ @Found5
DEC ECX
JZ @@NotFound
CMP AL, [EDX+5]
JZ @Found6
DEC ECX
JZ @@NotFound
CMP AL, [EDX+6]
JZ @Found7
DEC ECX
JZ @@NotFound
CMP AL, [EDX+7]
JZ @Found8
@@NotFound:
xor EAX, EAX
RET
@Found1:
MOV EAX, 1
RET
@Found2:
MOV EAX, 2
RET
@Found3:
MOV EAX, 3
RET
@Found4:
MOV EAX, 4
RET
@Found5:
MOV EAX, 5
RET
@Found6:
MOV EAX, 6
RET
@Found7:
MOV EAX, 7
RET
@Found8:
MOV EAX, 8
RET
@@NotSmall:
MOV AH, AL
ADD EDX, ECX
MOVD MM0, EAX
PSHUFW MM0, MM0, 0
PUSH ECX
NEG ECX
@@First8:
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare Next 8 Bytes}
PMOVMSKB EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
JGE @@Last8
@@Align:
LEA EAX, [EDX+ECX]
and EAX, 7
SUB ECX, EAX
@@Loop: {Loop Unrolled 2X}
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare Next 8 Bytes}
PMOVMSKB EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
{$IFNDEF NoUnroll}
JGE @@Last8
MOVQ MM1, [EDX+ECX]
ADD ECX, 8
PCMPEQB MM1, MM0 {Compare Next 8 Bytes}
PMOVMSKB EAX, MM1
TEST EAX, EAX
JNZ @@Matched {Exit on Match at any Position}
CMP ECX, -8 {Check if Next Loop would pass String End}
{$ENDIF}
JL @@loop
@@Last8:
PCMPEQB MM0, [EDX-8]
POP ECX {Original Length}
PMOVMSKB EAX, MM0
TEST EAX, EAX
JNZ @@Matched2
EMMS
RET {Finished}
@@Matched: {Set Result from 1st Match in EcX}
POP EDX {Original Length}
ADD ECX, EDX
@@Matched2:
EMMS
BSF EDX, EAX
LEA EAX, [EDX+ECX-7]
end;
{****************************************************************************}
function ALPos_SSE2(const SubStr: ansistring; const Str: ansistring): Integer;
asm
test eax, eax
jz @NotFoundExit {Exit if SurStr = ''}
test edx, edx
jz @NotFound {Exit if Str = ''}
mov ecx, [edx-4] {Length(Str)}
cmp[eax-4], 1 {Length SubStr = 1?}
je @SingleChar {Yes - Exit via CharPos}
jl @NotFound {Exit if Length(SubStr) < 1}
sub ecx, [eax-4] {Subtract Length(SubStr)}
jl @NotFound {Exit if Length(SubStr) > Length(Str)}
add ecx, 1 {Number of Chars to Check for 1st Char}
push esi {Save Registers}
push edi
push ebx
push ebp
mov esi, eax {Start Address of SubStr}
mov edi, ecx {Initial Remainder Count}
mov eax, [eax] {AL = 1st Char of SubStr}
mov ebp, edx {Start Address of Str}
mov ebx, eax {Maintain 1st Search Char in BL}
@StrLoop:
mov eax, ebx {AL = 1st char of SubStr}
mov ecx, edi {Remaining Length}
push edx {Save Start Position}
call @CharPos {Search for 1st Character}
pop edx {Restore Start Position}
test eax, eax {Result = 0?}
jz @StrExit {Exit if 1st Character Not Found}
mov ecx, [esi-4] {Length SubStr}
add edx, eax {Update Start Position for Next Loop}
sub edi, eax {Update Remaining Length for Next Loop}
sub ecx, 1 {Remaining Characters to Compare}
@StrCheck:
mov al, [edx+ecx-1] {Compare Next Char of SubStr and Str}
cmp al, [esi+ecx]
jne @StrLoop {Different - Return to First Character Search}
sub ecx, 1
jnz @StrCheck {Check each Remaining Character}
mov eax, edx {All Characters Matched - Calculate Result}
sub eax, ebp
@StrExit:
pop ebp {Restore Registers}
pop ebx
pop edi
pop esi
ret
@NotFound:
xor eax, eax {Return 0}
@NotFoundExit:
ret
@SingleChar:
mov al, [eax] {Search Character}
@CharPos:
PUSH EBX
MOV EBX, EAX
CMP ECX, 16
JL @@Small
@@NotSmall:
MOV AH, AL {Fill each Byte of XMM1 with AL}
MOVD XMM1, EAX
PSHUFLW XMM1, XMM1, 0
PSHUFD XMM1, XMM1, 0
@@First16:
MOVUPS XMM0, [EDX] {Unaligned}
PCMPEQB XMM0, XMM1 {Compare First 16 Characters}
PMOVMSKB EAX, XMM0
TEST EAX, EAX
JNZ @@FoundStart {Exit on any Match}
CMP ECX, 32
JL @@Medium {If Length(Str) < 32, Check Remainder}
@@Align:
SUB ECX, 16 {Align Block Reads}
PUSH ECX
MOV EAX, EDX
NEG EAX
and EAX, 15
ADD EDX, ECX
NEG ECX
ADD ECX, EAX
@@Loop:
MOVAPS XMM0, [EDX+ECX] {Aligned}
PCMPEQB XMM0, XMM1 {Compare Next 16 Characters}
PMOVMSKB EAX, XMM0
TEST EAX, EAX
JNZ @@Found {Exit on any Match}
ADD ECX, 16
JLE @@Loop
@Remainder:
POP EAX {Check Remaining Characters}
ADD EDX, 16
ADD EAX, ECX {Count from Last Loop End Position}
JMP DWORD PTR [@@JumpTable2-ECX*4]
@@NullString:
xor EAX, EAX {Result = 0}
RET
@@FoundStart:
BSF EAX, EAX {Get Set Bit}
POP EBX
ADD EAX, 1 {Set Result}
RET
@@Found:
POP EDX
BSF EAX, EAX {Get Set Bit}
ADD EDX, ECX
POP EBX
LEA EAX, [EAX+EDX+1] {Set Result}
RET
@@Medium:
ADD EDX, ECX {End of String}
MOV EAX, 16 {Count from 16}
JMP DWORD PTR [@@JumpTable1-64-ECX*4]
@@Small:
ADD EDX, ECX {End of String}
xor EAX, EAX {Count from 0}
JMP DWORD PTR [@@JumpTable1-ECX*4]
nop;
nop;
nop {Aligb Jump Tables}
@@JumpTable1:
DD @@NotFound, @@01, @@02, @@03, @@04, @@05, @@06, @@07
DD @@08, @@09, @@10, @@11, @@12, @@13, @@14, @@15, @@16
@@JumpTable2:
DD @@16, @@15, @@14, @@13, @@12, @@11, @@10, @@09, @@08
DD @@07, @@06, @@05, @@04, @@03, @@02, @@01, @@NotFound
@@16:
ADD EAX, 1
CMP BL, [EDX-16]
JE @@Done
@@15:
ADD EAX, 1
CMP BL, [EDX-15]
JE @@Done
@@14:
ADD EAX, 1
CMP BL, [EDX-14]
JE @@Done
@@13:
ADD EAX, 1
CMP BL, [EDX-13]
JE @@Done
@@12:
ADD EAX, 1
CMP BL, [EDX-12]
JE @@Done
@@11:
ADD EAX, 1
CMP BL, [EDX-11]
JE @@Done
@@10:
ADD EAX, 1
CMP BL, [EDX-10]
JE @@Done
@@09:
ADD EAX, 1
CMP BL, [EDX-9]
JE @@Done
@@08:
ADD EAX, 1
CMP BL, [EDX-8]
JE @@Done
@@07:
ADD EAX, 1
CMP BL, [EDX-7]
JE @@Done
@@06:
ADD EAX, 1
CMP BL, [EDX-6]
JE @@Done
@@05:
ADD EAX, 1
CMP BL, [EDX-5]
JE @@Done
@@04:
ADD EAX, 1
CMP BL, [EDX-4]
JE @@Done
@@03:
ADD EAX, 1
CMP BL, [EDX-3]
JE @@Done
@@02:
ADD EAX, 1
CMP BL, [EDX-2]
JE @@Done
@@01:
ADD EAX, 1
CMP BL, [EDX-1]
JE @@Done
@@NotFound:
xor EAX, EAX
@@Done:
POP EBX
end;
{**********************************}
{Called Once by Unit Initialisation}
procedure ALInitFastPosFunct;
var
aCpuInfo: TALCpuinfo;
begin
aCpuInfo := AlGetCpuInfo;
if (isSSE2 in aCpuInfo.InstructionSupport) then
ALPos := AlPos_SSE2 {Processor Supports SSE}
else if (isSSE in aCpuInfo.InstructionSupport) then
ALPos := AlPos_SSE {Processor Supports SSE}
else if (isMMX in aCpuInfo.InstructionSupport) then
ALPos := AlPos_MMX {Processor Supports MMX}
else
ALPos := ALPos_IA32; {Processor does not Support MMX or SSE}
end;
//***************************************************************************
procedure ALInitFastMovProc;
var
aCpuInfo: TALCpuinfo;
begin
aCpuInfo := AlGetCpuInfo;
if (isSSE in aCpuInfo.InstructionSupport) then
ALMove := AlMove_SSE {Processor Supports SSE}
else if (isMMX in aCpuInfo.InstructionSupport) then
ALMove := AlMove_MMX {Processor Supports MMX}
else
ALMove := ALMove_IA32; {Processor does not Support MMX or SSE}
end;
/////////////////////////////////////////
////////// TALSMTPClientHeader //////////
/////////////////////////////////////////
{********************************************************}
procedure TALSMTPClientHeader.AssignTo(Dest: TPersistent);
begin
if Dest is TALSMTPClientHeader then
with Dest as TALSMTPClientHeader do
begin
fSendTo := self.fSendTo;
fSender := self.fSender;
fMessageID := self.fMessageID;
fbcc := self.fbcc;
fContentTransferEncoding := self.fContentTransferEncoding;
fComments := self.fComments;
fMIMEVersion := self.fMIMEVersion;
fPriority := self.fPriority;
fReplyTo := self.fReplyTo;
fSubject := self.fSubject;
fFrom := self.fFrom;
fDate := self.fDate;
fDispositionNotificationTo := self.fDispositionNotificationTo;
fReferences := self.fReferences;
fcc := self.fcc;
fContentType := self.fContentType;
FCustomHeaders.Assign(FCustomHeaders);
end
else
inherited AssignTo(Dest);
end;
{**********************************}
procedure TALSMTPClientHeader.Clear;
begin
fSendTo := '';
fSender := '';
fMessageID := '';
fbcc := '';
fContentTransferEncoding := '';
fComments := '';
fMIMEVersion := '';
fPriority := '';
fReplyTo := '';
fSubject := '';
fFrom := '';
fDate := '';
fDispositionNotificationTo := '';
fReferences := '';
fcc := '';
fContentType := '';
FCustomHeaders.Clear;
end;
{*************************************}
constructor TALSMTPClientHeader.Create;
begin
inherited Create;
FCustomHeaders := TStringList.Create;
FCustomHeaders.NameValueSeparator := ':';
Clear;
fMessageID := 'AUTO';
fMIMEVersion := '1.0';
fDate := 'NOW';
fContentType := 'text/plain';
end;
{*************************************}
destructor TALSMTPClientHeader.Destroy;
begin
FCustomHeaders.Free;
inherited;
end;
{****************************************************}
function TALSMTPClientHeader.GetRawHeaderText: String;
var
i: Integer;
Str: String;
begin
Result := '';
if Trim(fFrom) <> '' then
Result := Result + 'From: ' + trim(fFrom) + #13#10;
if Trim(fSender) <> '' then
Result := Result + 'Sender: ' + trim(fSender) + #13#10;
if Trim(fSendTo) <> '' then
Result := Result + 'To: ' + trim(fSendTo) + #13#10;
if Trim(fcc) <> '' then
Result := Result + 'cc: ' + trim(fcc) + #13#10;
if Trim(fbcc) <> '' then
Result := Result + 'bcc: ' + trim(fbcc) + #13#10;
if Trim(fReplyTo) <> '' then
Result := Result + 'Reply-To: ' + trim(fReplyTo) + #13#10;
if Trim(fSubject) <> '' then
Result := Result + 'Subject: ' + trim(fSubject) + #13#10;
Str := fMessageID;
if Trim(str) <> '' then
begin
if sametext(Str, 'AUTO') then
Str := '<' + AlSMTPClientGenerateMessageID + '>';
Result := Result + 'Message-ID: ' + trim(str) + #13#10;
end;
if Trim(fReferences) <> '' then
Result := Result + 'References: ' + trim(fReferences) + #13#10;
if Trim(fComments) <> '' then
Result := Result + 'Comments: ' + trim(fComments) + #13#10;
Str := fDate;
if Trim(str) <> '' then
begin
if sametext(Str, 'NOW') then
Str := ALDateTimeToRfc822Str(Now);
Result := Result + 'Date: ' + trim(str) + #13#10;
end;
if Trim(fContentType) <> '' then
Result := Result + 'Content-Type: ' + trim(fContentType) + #13#10;
if Trim(fContentTransferEncoding) <> '' then
Result := Result + 'Content-Transfer-Encoding: ' + trim(fContentTransferEncoding) + #13#10;
if Trim(fMIMEVersion) <> '' then
Result := Result + 'MIME-Version: ' + trim(fMIMEVersion) + #13#10;
if Trim(fPriority) <> '' then
Result := Result + 'Priority: ' + trim(fPriority) + #13#10;
if Trim(fDispositionNotificationTo) <> '' then
Result := Result + 'Disposition-Notification-To: ' + trim(fDispositionNotificationTo) + #13#10;
for i := 0 to FCustomHeaders.Count - 1 do
if (trim(FCustomHeaders.names[i]) <> '') and (trim(FCustomHeaders.ValueFromIndex[i]) <> '') then
Result := Result + FCustomHeaders.names[i] + ': ' + trim(FCustomHeaders.ValueFromIndex[i]) + #13#10;
end;
{***************************************************************************}
procedure TALSMTPClientHeader.SetRawHeaderText(const aRawHeaderText: String);
var
aRawHeaderLst: TStringList;
{-------------------------------------}
function AlG001(aName: String): String;
var
i: Integer;
Str: String;
begin
I := aRawHeaderLst.IndexOfName(aName);
if I >= 0 then
begin
Result := Trim(aRawHeaderLst.ValueFromIndex[i]);
aRawHeaderLst.Delete(i);
while True do
begin
if i >= aRawHeaderLst.Count then
break;
str := aRawHeaderLst[i];
if (str = '') or
(not (str[1] in [' ', #9])) then
break; //(1) an empty line or (2) a line that does not start with a space, a tab, or a field name followed by a colon
Result := trim(Result + ' ' + trim(str));
aRawHeaderLst.Delete(i);
end;
end
else
Result := '';
end;
var
Str1, Str2: String;
j: Integer;
begin
aRawHeaderLst := TStringList.Create;
try
aRawHeaderLst.NameValueSeparator := ':';
aRawHeaderLst.Text := aRawHeaderText;
fFrom := Alg001('From');
fSender := Alg001('Sender');
fSendTo := Alg001('To');
fcc := Alg001('cc');
fbcc := Alg001('bcc');
fReplyTo := Alg001('Reply-To');
fSubject := Alg001('Subject');
fMessageID := Alg001('Message-ID');
fReferences := Alg001('References');
fComments := Alg001('Comments');
fDate := Alg001('Date');
fContentType := Alg001('Content-Type');
fContentTransferEncoding := Alg001('Content-Transfer-Encoding');
fMIMEVersion := Alg001('MIME-Version');
fPriority := Alg001('Priority');
fDispositionNotificationTo := Alg001('Disposition-Notification-To');
FCustomHeaders.Clear;
J := 0;
while j <= aRawHeaderLst.Count - 1 do
begin
Str1 := trim(aRawHeaderLst.Names[j]);
if (trim(str1) <> '') and (not (str1[1] in [' ', #9])) then
begin
Str1 := trim(Str1) + ': ' + trim(aRawHeaderLst.ValueFromIndex[j]);
Inc(j);
while True do
begin
if j >= aRawHeaderLst.Count then
break;
str2 := aRawHeaderLst[j];
if (str2 = '') or
(not (str2[1] in [' ', #9])) then
break; //(1) an empty line or (2) a line that does not start with a space, a tab, or a field name followed by a colon
Str1 := trim(Str1 + ' ' + trim(str2));
Inc(j);
end;
FCustomHeaders.Add(Str1);
end
else
Inc(j);
end;
finally
aRawHeaderLst.Free;
end;
end;
///////////////////////////////////
////////// TAlSmtpClient //////////
///////////////////////////////////
{*******************************}
constructor TAlSmtpClient.Create;
begin
FWSAData.wVersion := 0;
Fconnected := False;
FSocketDescriptor := INVALID_SOCKET;
FAuthTypesSupported := [];
Ftimeout := 60000;
Randomize;
end;
{*******************************}
destructor TAlSmtpClient.Destroy;
begin
if Fconnected then
Disconnect;
inherited;
end;
{*************************************************}
procedure TAlSmtpClient.CheckError(Error: Boolean);
var
ErrCode: Integer;
S: String;
begin
ErrCode := WSAGetLastError;
if Error and (ErrCode <> 0) then
begin
case ErrCode of
WSAEINTR: S := 'Interrupted function call';
WSAEACCES: S := 'Permission denied';
WSAEFAULT: S := 'Bad address';
WSAEINVAL: S := 'Invalid argument';
WSAEMFILE: S := 'Too many open files';
WSAEWOULDBLOCK: S := 'Resource temporarily unavailable';
WSAEINPROGRESS: S := 'Operation now in progress';
WSAEALREADY: S := 'Operation already in progress';
WSAENOTSOCK: S := 'Socket operation on nonsocket';
WSAEDESTADDRREQ: S := 'Destination address required';
WSAEMSGSIZE: S := 'Message too long';
WSAEPROTOTYPE: S := 'Protocol wrong type for socket';
WSAENOPROTOOPT: S := 'Bad protocol option';
WSAEPROTONOSUPPORT: S := 'Protocol not supported';
WSAESOCKTNOSUPPORT: S := 'Socket type not supported';
WSAEOPNOTSUPP: S := 'Operation not supported';
WSAEPFNOSUPPORT: S := 'Protocol family not supported';
WSAEAFNOSUPPORT: S := 'Address family not supported by protocol family';
WSAEADDRINUSE: S := 'Address already in use';
WSAEADDRNOTAVAIL: S := 'Cannot assign requested address';
WSAENETDOWN: S := 'Network is down';
WSAENETUNREACH: S := 'Network is unreachable';
WSAENETRESET: S := 'Network dropped connection on reset';
WSAECONNABORTED: S := 'Software caused connection abort';
WSAECONNRESET: S := 'Connection reset by peer';
WSAENOBUFS: S := 'No buffer space available';
WSAEISCONN: S := 'Socket is already connected';
WSAENOTCONN: S := 'Socket is not connected';
WSAESHUTDOWN: S := 'Cannot send after socket shutdown';
WSAETIMEDOUT: S := 'Connection timed out';
WSAECONNREFUSED: S := 'Connection refused';
WSAEHOSTDOWN: S := 'Host is down';
WSAEHOSTUNREACH: S := 'No route to host';
WSAEPROCLIM: S := 'Too many processes';
WSASYSNOTREADY: S := 'Network subsystem is unavailable';
WSAVERNOTSUPPORTED: S := 'Winsock.dll version out of range';
WSANOTINITIALISED: S := 'Successful WSAStartup not yet performed';
WSAEDISCON: S := 'Graceful shutdown in progress';
WSAHOST_NOT_FOUND: S := 'Host not found';
WSATRY_AGAIN: S := 'Nonauthoritative host not found';
WSANO_RECOVERY: S := 'This is a nonrecoverable error';
WSANO_DATA: S := 'Valid name, no data record of requested type';
else
begin
SetLength(S, 256);
FormatMessage(
FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_FROM_HMODULE,
Pointer(GetModuleHandle('wsock32.dll')),
ErrCode,
0,
PChar(S),
Length(S),
nil
);
SetLength(S, StrLen(PChar(S)));
while (Length(S) > 0) and (S[Length(S)] in [#10, #13]) do
SetLength(S, Length(S) - 1);
end;
end;
raise Exception.Create(Format('%s (Error code:%s)', [S, IntToStr(ErrCode)])); { Do not localize }
end;
end;
{********************************************************************}
function TAlSmtpClient.Connect(aHost: String; APort: Integer): String;
{---------------------------------------------}
procedure CallServer(Server: String; Port: Word);
var
SockAddr: Sockaddr_in;
IP: String;
begin
FSocketDescriptor := Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
CheckError(FSocketDescriptor = INVALID_SOCKET);
FillChar(SockAddr, SizeOf(SockAddr), 0);
SockAddr.sin_family := AF_INET;
SockAddr.sin_port := swap(Port);
{$IFDEF DELPHI12}
SockAddr.sin_addr.S_addr := inet_addr( PAnsiChar(Server) );
{$ELSE}
SockAddr.sin_addr.S_addr := inet_addr(PChar(Server));
{$ENDIF}
if SockAddr.sin_addr.S_addr = INADDR_NONE then
begin
checkError(ALHostToIP(Server, IP));
{$IFDEF DELPHI12}
SockAddr.sin_addr.S_addr := inet_addr(pAnsiChar(IP));
{$ELSE}
SockAddr.sin_addr.S_addr := inet_addr(PChar(IP));
{$ENDIF}
end;
CheckError(WinSock.Connect(FSocketDescriptor, SockAddr, SizeOf(SockAddr)) = SOCKET_ERROR);
end;
begin
if FConnected then
raise Exception.Create('SMTP component already connected');
try
WSAStartup(MAKEWORD(2, 2), FWSAData);
CallServer(aHost, aPort);
{$IFDEF DELPHI12}
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_RCVTIMEO, PAnsiChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_SNDTIMEO, PAnsiChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
{$ELSE}
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_RCVTIMEO, PChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_SNDTIMEO, PChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
{$ENDIF}
Result := GetResponse([220]);
FAuthTypesSupported := [];
Fconnected := True;
except
Disconnect;
raise;
end;
end;
{*********************************}
procedure TAlSmtpClient.Disconnect;
begin
if Fconnected then
begin
ShutDown(FSocketDescriptor, SD_BOTH);
CloseSocket(FSocketDescriptor);
FSocketDescriptor := INVALID_SOCKET;
if FWSAData.wVersion = 2 then
WSACleanup;
FWSAData.wVersion := 0;
Fconnected := False;
if Assigned(OnStatus) then
OnStatus('Disconnect');
end;
end;
{********************}
{EhloResponse is like:
250-ec-is.net Hello your_name, ravi de vous rencontrer
250-VRFY
250-ETRN
250-AUTH=LOGIN
250-AUTH LOGIN CRAM-MD5
250-8BITMIME
250 SIZE 0}
function TAlSmtpClient.GetAuthTypeFromEhloResponse(EhloResponse: String): TAlSmtpClientAuthTypeSet;
var
k, J: Integer;
Str1, Str2: String;
Lst: TStringList;
begin
Result := [];
Lst := TStringList.Create;
try
Lst.Text := AlUpperCase(Trim(EhloResponse));
for j := 0 to Lst.Count - 1 do
begin
Str1 := trim(Lst[J]); //250-AUTH=LOGIN
Delete(Str1, 1, 4); //AUTH=LOGIN
Str2 := AlCopyStr(Str1, 1, 5); //AUTH=
if (str2 = 'AUTH ') or (Str2 = 'AUTH=') then
begin
Str1 := AlCopyStr(Str1, 6, maxint); //LOGIN
Str1 := AlStringReplace(Str1, '=', ' ', [rfReplaceAll]); //LOGIN
while (str1 <> '') do
begin
K := AlCharPos(' ', Str1);
if K <= 0 then
begin
Str2 := trim(Str1);
Str1 := '';
end
else
begin
Str2 := Trim(AlCopyStr(Str1, 1, k - 1));
Delete(Str1, 1, k);
end;
if Str2 = ('PLAIN') then
Result := Result + [AlsmtpClientAuthPlain]
else if Str2 = ('LOGIN') then
Result := Result + [AlsmtpClientAuthLogin]
else if Str2 = ('CRAM-MD5') then
Result := Result + [AlsmtpClientAuthCramMD5]
else if Str2 = ('CRAM-SHA1') then
Result := Result + [AlsmtpClientAuthCramSHA1];
end;
end;
end;
finally
Lst.Free;
end;
end;
{****************************************************************************************}
{This command is used to identify the sender-SMTP to the receiver-SMTP. The argument field
contains the host name of the sender-SMTP. The receiver-SMTP identifies itself to the
sender-SMTP in the connection greeting reply, and in the response to this command.
This command and an OK reply to it confirm that both the sender-SMTP and the receiver-SMTP
are in the initial state, that is, there is no transaction in progress and all state tables
and buffers are cleared.}
function TAlSmtpClient.Helo: String;
begin
Result := SendCmd('HELO ' + AlGetLocalHostName, [250]);
end;
{**********************************}
function TAlSmtpClient.Ehlo: String;
begin
Result := SendCmd('EHLO ' + AlGetLocalHostName, [250]);
FAuthTypesSupported := GetAuthTypeFromEhloResponse(Result);
end;
{****************************************************************************}
{This command is used to initiate a mail transaction in which the mail data is
delivered to one or more mailboxes. The argument field contains a reverse-path.
The reverse-path consists of an optional list of hosts and the sender mailbox. When
the list of hosts is present, it is a "reverse" source route and indicates that the
mail was relayed through each host on the list (the first host in the list was the
most recent relay). This list is used as a source route to return non-delivery notices
to the sender. As each relay host adds itself to the beginning of the list, it must
use its name as known in the IPCE to which it is relaying the mail rather than the IPCE
from which the mail came (if they are different). In some types of error reporting
messages (for example, undeliverable mail notifications) the reverse-path may be null.
This command clears the reverse-path buffer, the forward-path buffer, and the mail data
buffer; and inserts the reverse-path information from this command into the reverse-path buffer.}
function TAlSmtpClient.MailFrom(aFromName: String): String;
begin
aFromName := trim(aFromName);
if aFromName = '' then
raise Exception.Create('From name is empty');
if AlPos(#13#10, aFromName) > 0 then
raise Exception.Create('From name is invalid');
Result := SendCmd('MAIL From:<' + aFromName + '>', [250]);
end;
{**************************************************************************************************}
function TAlSmtpClient.Auth(AUserName, APassword: String; aAuthType: TalSmtpClientAuthType): String;
{-----------------------------------}
function InternalDoAuthPlain: String;
var
aAuthPlain: String;
begin
if aUserName = '' then
raise Exception.Create('UserName is empty');
if aPassword = '' then
raise Exception.Create('Password is empty');
aAuthPlain := ALMimeBase64EncodeStringNoCRLF(aUserName + #0 + aUserName + #0 + aPassword);
Result := SendCmd('AUTH PLAIN ' + aAuthPlain, [235]);
end;
{-----------------------------------}
function InternalDoAuthLogin: String;
begin
if aUserName = '' then
raise Exception.Create('UserName is empty');
if aPassword = '' then
raise Exception.Create('Password is empty');
SendCmd('AUTH LOGIN', [334]);
SendCmd(ALMimeBase64EncodeStringNoCRLF(aUsername), [334]);
Result := SendCmd(ALMimeBase64EncodeStringNoCRLF(aPassword), [235]);
end;
var
tmpAuthType: TAlSmtpClientAuthType;
begin
if aAuthType = AlsmtpClientAuthAutoSelect then
begin
if AlsmtpClientAuthPlain in FAuthTypesSupported then
tmpAuthType := AlsmtpClientAuthPlain
else if AlsmtpClientAuthLogin in FAuthTypesSupported then
tmpAuthType := AlsmtpClientAuthLogin
else if AlsmtpClientAuthCramMD5 in FAuthTypesSupported then
tmpAuthType := AlsmtpClientAuthCramMD5
else if AlsmtpClientAuthCramSHA1 in FAuthTypesSupported then
tmpAuthType := AlsmtpClientAuthCramSHA1
else
tmpAuthType := AlsmtpClientAuthNone;
end
else
tmpAuthType := aAuthType;
if Assigned(OnStatus) then
OnStatus('Authentication');
case tmpAuthType of
alsmtpClientAuthPlain: Result := InternalDoAuthPlain;
alsmtpClientAuthLogin: Result := InternalDoAuthLogin;
alsmtpClientAuthCramMD5: raise Exception.Create('CRAM-MD5 Authentication is not supported yet!');
alsmtpClientAuthCramSHA1: raise Exception.Create('CRAM-SHA1 Authentication is not supported yet!');
else
raise Exception.Create('No Authentication scheme found');
end;
end;
{*************************************************************************}
{This command is used to identify an individual recipient of the mail data;
multiple recipients are specified by multiple use of this command.}
function TAlSmtpClient.RcptTo(aRcptNameLst: TStrings): String;
var
i: Integer;
aRcptNameValue: String;
begin
Result := '';
if aRcptNameLst.Count <= 0 then
raise Exception.Create('RcptName list is empty');
for i := 0 to aRcptNameLst.Count - 1 do
begin
aRcptNameValue := trim(aRcptNameLst[i]);
if (aRcptNameValue = '') or (AlPos(#13#10, aRcptNameValue) > 0) then
raise Exception.Create('Bad entry in RcptName list');
Result := Result + SendCmd('RCPT To:<' + aRcptNameValue + '>', [250, 251]) + #13#10;
end;
if Result <> '' then
Delete(Result, Length(Result) - 1, 2);
end;
{********************************************************************************}
{The receiver treats the lines following the command as mail data from the sender.
This command causes the mail data from this command to be appended to the mail data buffer.
The mail data may contain any of the 128 ASCII character codes.
The mail data is terminated by a line containing only a period, that is the character sequence "<CRLF>.<CRLF>".
This is the end of mail data indication. The end of mail data indication requires that the receiver must now process
the stored mail transaction information. This processing consumes the information in the reverse-path buffer,
the forward-path buffer, and the mail data buffer, and on the completion of this command these buffers are cleared.
If the processing is successful the receiver must send an OK reply. If the processing fails completely
the receiver must send a failure reply. When the receiver-SMTP accepts a message either for relaying or for
final delivery it inserts at the beginning of the mail data a time stamp line. The time stamp line indicates the
identity of the host that sent the message, and the identity of the host that received the message (and is inserting this
time stamp), and the date and time the message was received. Relayed messages will have multiple time stamp lines.
When the receiver-SMTP makes the "final delivery" of a message it inserts at the beginning of the mail data a return path
line. The return path line preserves the information in the <reverse-path> from the MAIL command. Here, final delivery
means the message leaves the SMTP world. Normally, this would mean it has been delivered to the destination user, but
in some cases it may be further processed and transmitted by another mail system.
It is possible for the mailbox in the return path be different from the actual sender's mailbox, for example,
if error responses are to be delivered a special error handling mailbox rather than the message senders.
The preceding two paragraphs imply that the final mail data will begin with a return path line, followed
by one or more time stamp lines. These lines will be followed by the mail data header and body [2].
Special mention is needed of the response and further action required when the processing following the end of mail
data indication is partially successful. This could arise if after accepting several recipients and the mail data,
the receiver-SMTP finds that the mail data can be successfully delivered to some of the recipients, but it cannot
be to others (for example, due to mailbox space allocation problems). In such a situation, the response to the DATA
command must be an OK reply. But, the receiver-SMTP must compose and send an "undeliverable mail" notification
message to the originator of the message. Either a single notification which lists all of the recipients that failed
to get the message, or separate notification messages must be sent for each failed recipient. All undeliverable mail
notification messages are sent using the MAIL command (even if they result from processing a SEND, SOML, or SAML command).}
function TAlSmtpClient.Data(aMailData: String): String;
var
I: Integer;
begin
SendCmd('DATA', [354]);
i := 2;
while i <= Length(aMailData) do
begin
if (aMailData[i] = '.') and (aMailData[i - 1] = #10) and (aMailData[i - 2] = #13) then
Insert('.', aMailData, i);
Inc(i);
end;
Result := SendCmd(aMailData + #13#10 + '.', [250]);
end;
{**********************************************************}
function TAlSmtpClient.Data(aHeader, aBody: String): String;
begin
Result := Data(Trim(aHeader) + #13#10#13#10 + aBody);
end;
{******************************************************************************}
function TAlSmtpClient.Data(aHeader: TALSMTPClientHeader; aBody: String): String;
begin
Result := Data(aHeader.GetRawHeaderText, aBody);
end;
{**************************************************************}
{This command specifies that the receiver must send an OK reply,
and then close the transmission channel. The receiver should not
close the transmission channel until it receives and replies to
a QUIT command (even if there was an error). The sender should not
close the transmission channel until it send a QUIT command and
receives the reply (even if there was an error response to a previous
command). If the connection is closed prematurely the receiver should
act as if a RSET command had been received (canceling any pending
transaction, but not undoing any previously completed transaction),
the sender should act as if the command or transaction in progress had
received a temporary error (4xx).}
function TAlSmtpClient.Quit: String;
begin
Result := SendCmd('QUIT', [221]);
Disconnect;
end;
{**********************************}
{This command asks the receiver to confirm that the argument identifies a user.
If it is a user name, the full name of the user (if known) and the fully
specified mailbox are returned. This command has no effect on any of the
reverse-path buffer, the forward-path buffer, or the mail data buffer.}
function TAlSmtpClient.Vrfy(aUserName: String): String;
begin
Result := SendCmd('VRFY ' + aUserName, [250]);
end;
{*************************************************************}
{This command specifies that the current mail transaction is to
be aborted. Any stored sender, recipients, and mail data must be
discarded, and all buffers and state tables cleared. The receiver
must send an OK reply.}
function TAlSmtpClient.Rset: String;
begin
Result := SendCmd('RSET', [250]);
end;
{*********************************************}
procedure TAlSmtpClient.SendMail(aHost: String; APort: Integer; aFromName: String; aRcptNameLst: TStrings; AUserName, APassword: String; aAuthType: TalSmtpClientAuthType; aMailData: String);
begin
if Fconnected then
Disconnect;
connect(aHost, APort);
try
if aAuthType = AlsmtpClientAuthAutoSelect then
ehlo
else
Helo;
if aAuthType <> AlsmtpClientAuthNone then
Auth(AUserName, APassword, aAuthType);
mailFrom(aFromName);
RcptTo(aRcptNameLst);
Data(aMailData);
Quit;
finally
Disconnect;
end;
end;
{*********************************************}
procedure TAlSmtpClient.SendMail(aHost: String; APort: Integer; aFromName: String; aRcptNameLst: TStrings; AUserName, APassword: String; aAuthType: TalSmtpClientAuthType; aHeader, aBody: String);
begin
if Fconnected then
Disconnect;
if Assigned(OnStatus) then
OnStatus('Wait for connection');
connect(aHost, APort);
try
if aAuthType = AlsmtpClientAuthAutoSelect then
ehlo
else
Helo;
if aAuthType <> AlsmtpClientAuthNone then
Auth(AUserName, APassword, aAuthType);
if Assigned(OnStatus) then
OnStatus('Send email');
mailFrom(aFromName);
RcptTo(aRcptNameLst);
Data(aHeader, aBody);
Quit;
finally
Disconnect;
end;
end;
{***********************************************************}
{*******************************************************************************}
{commands consist of a command code followed by an argument field. Command codes
are four alphabetic characters. Upper and lower case alphabetic characters are
to be treated identically. Thus, any of the following may represent the mail command:
MAIL Mail mail MaIl mAIl
This also applies to any symbols representing parameter values, such as "TO" or "to"
for the forward-path. Command codes and the argument fields are separated by one or
more spaces. However, within the reverse-path and forward-path arguments case is
important. In particular, in some hosts the user "smith" is different from the user
"Smith". The argument field consists of a variable length character string ending
with the character sequence <CRLF>. The receiver is to take no action until
this sequence is received. Square brackets denote an optional argument field.
If the option is not taken, the appropriate default is implied.
The following are the SMTP commands:
HELO <SP> <domain> <CRLF>
MAIL <SP> FROM:<reverse-path> <CRLF>
RCPT <SP> TO:<forward-path> <CRLF>
DATA <CRLF>
RSET <CRLF>
SEND <SP> FROM:<reverse-path> <CRLF>
SOML <SP> FROM:<reverse-path> <CRLF>
SAML <SP> FROM:<reverse-path> <CRLF>
VRFY <SP> <string> <CRLF>
EXPN <SP> <string> <CRLF>
HELP [<SP> <string>] <CRLF>
NOOP <CRLF>
QUIT <CRLF>
TURN <CRLF>}
function TAlSmtpClient.SendCmd(aCmd: String; OkResponses: array of Word): String;
var
P: PChar;
L: Integer;
ByteSent: Integer;
begin
if (length(aCmd) <= 1) or
(aCmd[length(aCmd)] <> #10) or
(aCmd[length(aCmd) - 1] <> #13) then
aCmd := aCmd + #13#10;
p := @aCmd[1]; // pchar
l := length(aCmd);
while l > 0 do
begin
ByteSent := SocketWrite(p^, l);
if ByteSent <= 0 then
raise Exception.Create('Connection close gracefully!');
Inc(p, ByteSent);
Dec(l, ByteSent);
end;
Result := GetResponse(OkResponses);
end;
{*********************************************************************}
{An SMTP reply consists of a three digit number (transmitted as three
alphanumeric characters) followed by some text. The number is intended
for use by automata to determine what state to enter next; the text is
meant for the human user. It is intended that the three digits contain
enough encoded information that the sender-SMTP need not examine the
text and may either discard it or pass it on to the user, as appropriate.
In particular, the text may be receiver-dependent and context dependent,
so there are likely to be varying texts for each reply code. Formally,
a reply is defined to be the sequence:
a three-digit code, <SP>, one line of text, and <CRLF>, or a multiline reply.
Only the EXPN and HELP commands are expected to result in multiline replies
in normal circumstances, however multiline replies are allowed for any
command.}
function TAlSmtpClient.GetResponse(OkResponses: array of Word): String;
{----------------------------------------------}
function Internalstpblk(PValue: PChar): PChar;
begin
Result := PValue;
{$IFDEF DELPHI12}
while CharinSet(Result^,[' ', #9, #10, #13]) do
{$ELSE}
while Result^ in [' ', #9, #10, #13] do
{$ENDIF}
Inc(Result);
end;
{---------------------------------------------------------------------}
function InternalGetInteger(Data: PChar; var Number: Integer): PChar;
var
bSign: Boolean;
begin
Number := 0;
Result := InternalStpBlk(Data);
if (Result = nil) then
Exit;
{ Remember the sign }
{$IFDEF DELPHI12}
If CharInSet(Result^,['-', '+']) then
{$ELSE}
if Result^ in ['-', '+'] then
{$ENDIF}
begin
bSign := (Result^ = '-');
Inc(Result);
end
else
bSign := False;
{ Convert any number }
{$IFDEF DELPHI12}
while ( CharInSet(Result^,[#0]) ) and ( CharInSet(Result^,['0'..'9']) ) do
{$ELSE}
while (Result^ <> #0) and (Result^ in ['0'..'9']) do
{$ENDIF}
begin
Number := Number * 10 + Ord(Result^) - Ord('0');
Inc(Result);
end;
{ Correct for sign }
if bSign then
Number := -Number;
end;
var
aBuffStr: String;
aBuffStrLength: Integer;
aResponse: String;
aStatusCode: Integer;
aGoodResponse: Boolean;
ALst: TStringList;
P: PChar;
i, j: Integer;
begin
Result := '';
while True do
begin
{Read the response from the socket - end of the response is show by <CRLF>}
aResponse := '';
while True do
begin
Setlength(aBuffStr, 512); //The maximum total length of a reply line including the reply code and the <CRLF> is 512 characters. (http://www.freesoft.org/CIE/RFC/821/24.htm)
aBuffStrLength := SocketRead(aBuffStr[1], length(aBuffStr));
aResponse := AResponse + AlCopyStr(aBuffStr, 1, aBuffStrLength);
if aResponse = '' then
raise Exception.Create('Connection close gracefully!');
if (aBuffStrLength > 1) and
(aBuffStr[aBuffStrLength] = #10) and
(aBuffStr[aBuffStrLength - 1] = #13) then
Break;
end;
Result := Result + aResponse;
{The format for multiline replies requires that every line, except the last,
begin with the reply code, followed immediately by a hyphen, "-" (also known as minus),
followed by text. The last line will begin with the reply code, followed immediately
by <SP>, optionally some text, and <CRLF>.}
ALst := TStringList.Create;
try
Alst.Text := aResponse;
if Alst.Count = 0 then
raise Exception.Create('Emtpy response');
for j := 0 to Alst.Count - 1 do
begin
aResponse := Alst[j];
p := InternalGetInteger(@aResponse[1], aStatusCode);
aGoodResponse := False;
for I := 0 to High(OkResponses) do
if OkResponses[I] = aStatusCode then
begin
aGoodResponse := True;
Break;
end;
if not aGoodResponse then
raise Exception.Create(aResponse);
if p^ <> '-' then
begin
if J <> Alst.Count - 1 then
raise Exception.Create(aResponse);
Exit;
end;
end;
finally
ALst.Free;
end;
end;
end;
{**********************************************************************}
function TAlSmtpClient.SocketWrite(var Buffer; Count: longint): longint;
begin
Result := Send(FSocketDescriptor, Buffer, Count, 0);
CheckError(Result = SOCKET_ERROR);
end;
{*********************************************************************}
function TAlSmtpClient.SocketRead(var Buffer; Count: longint): longint;
begin
Result := Recv(FSocketDescriptor, Buffer, Count, 0);
CheckError(Result = SOCKET_ERROR);
end;
{*******************************************************}
procedure TAlSmtpClient.Settimeout(const Value: Integer);
begin
if Value <> Ftimeout then
begin
{$IFDEF DELPHI12}
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_RCVTIMEO, PAnsiChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_SNDTIMEO, PAnsiChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
{$ELSE}
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_RCVTIMEO, PChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
CheckError(setsockopt(FSocketDescriptor, SOL_SOCKET, SO_SNDTIMEO, PChar(@FTimeOut), SizeOf(integer)) = SOCKET_ERROR);
{$ENDIF}
Ftimeout := Value;
end;
end;
initialization
for Ch := #0 to #255 do
VALMove_AnsiUpcase[Ch] := Ch;
CharUpperBuff(@VALMove_AnsiUpcase, 256);
ALInitFastMovProc;
ALInitFastPosFunct;
end.
Reference in New Issue Copy Permalink