{************************************************************* Author: Stéphane Vander Clock (SVanderClock@Arkadia.com) Contributor Franç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é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 - 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 - 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 - 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: , "Giant; \"Big\" Box" - 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: , "Giant; \"Big\" Box" - 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" - 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 ".". 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 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 . 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 MAIL FROM: RCPT TO: DATA RSET SEND FROM: SOML FROM: SAML FROM: VRFY EXPN HELP [ ] NOOP QUIT TURN } 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, , one line of text, and , 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 } aResponse := ''; while True do begin Setlength(aBuffStr, 512); //The maximum total length of a reply line including the reply code and the 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 , optionally some text, and .} 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.