alsmtpclient.pas

Description: TALsmtpClient class implements the SMTP protocol (RFC-821)

{*************************************************************
Author:       St閜hane Vander Clock ([e-mail])

Contributor   Fran鏾is PIETTE (http://www.overbyte.be)
              Paul TOTH ([e-mail] - http://tothpaul.free.fr)

EMail:        http://www.arkadia.com
              [e-mail]

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閜hane 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 [e-mail]
**************************************************************}
unit ALSMTPClient;

interface

uses windows,
     Classes,
     WinSock,
     ALMultiPartMixedParser;

type

    {-----------------------}
    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 <[e-mail]> - 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 <[e-mail]> - 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 <[e-mail]> - 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: <[e-mail]>, "Giant; \"Big\" Box" <[e-mail]> - 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: <[e-mail]>, "Giant; \"Big\" Box" <[e-mail]> - 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" <[e-mail]> - 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: <[e-mail]> -	Unique ID for the message RFC 822: 4.6.1; RFC 1036: 2.1.5}
      property References: String read fReferences write fReferences; {References: <[e-mail]> <[e-mail]> - 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 [e-mail] - 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: [e-mail] - 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;

    {----------------------------}
    TAlSmtpClient = class(TObject)
    Private
      FWSAData : TWSAData;
      Fconnected: Boolean;
      FSocketDescriptor: Integer;
      FAuthTypesSupported: TAlSmtpClientAuthTypeSet;
      Ftimeout: integer;
      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 DataMultipartMixed(aHeader: TALSMTPClientHeader; aInlineText, aInlineTextContentType: String; aAttachments: TALMultiPartMixedAttachments): String; 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 SendMailMultipartMixed(aHost: String; APort: integer; aFromName: String; aRcptNameLst: Tstrings; AUserName, APassword: String; aAuthType: TalSmtpClientAuthType; aHeader: TALSMTPClientHeader; aInlineText, aInlineTextContentType: String; aAttachments: TALMultiPartMixedAttachments); virtual;
      Procedure Disconnect; virtual;
      Function GetAuthTypeFromEhloResponse(EhloResponse: string): TAlSmtpClientAuthTypeSet; virtual;
      property Connected: Boolean read FConnected;
      Property Timeout: integer read Ftimeout write Settimeout default 60000;
    end;

{----------------------------------------------------------------------------------------}
function AlSMTPClientParseEmail(FriendlyEmail: String; var FriendlyName : String): String;
Function AlSMTPClientGenerateMessageID: String;

implementation

Uses SysUtils,
     AlFcnMime,
     AlFcnWinsock,
     AlFcnRfc,
     AlFcnMisc,
     AlFcnString;

{***************************************************************************}
{ FriendlyEmail                  FriendlyName   Result                      }
{ ----------------------------   ------------   --------------              }
{ myname <[e-mail]>       'myname'       [e-mail]             }
{ myname [e-mail]         'myname'       [e-mail]             }
{ "my name" <[e-mail]>    'my name'      [e-mail]             }
{ 'my name' <[e-mail]>    'my name'      [e-mail]             }
{ [e-mail]                empty          [e-mail]             }
{ <[e-mail]>              empty          [e-mail]             }
{ "[e-mail]"              empty          [e-mail]             }
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 begin
    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;
  end;
  if (Result = '') and (AlCharPos('@', FriendlyName) > 0) then begin
    Result := FriendlyName;
    FriendlyName := '';
  end;
end;

{*********************************************}
Function AlSMTPClientGenerateMessageID: String;
Begin
  Result := AlStringReplace(ALMakeKeyStrByGUID,'-','',[rfReplaceAll]) + '@' + AlGetLocalHostName;
end;




/////////////////////////////////////////
////////// TALSMTPClientHeader //////////
/////////////////////////////////////////

{********************************************************}
procedure TALSMTPClientHeader.AssignTo(Dest: TPersistent);
begin
  if Dest is TALSMTPClientHeader then begin
    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;