mail2000.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

unit Mail2000;

{Please don't remove the following line:}
{$BOOLEVAL OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  WinSock, ScktComp, Math, Registry, ExtCtrls;

type

  TMailPartList = class;
  TMailMessage2000 = class;
  TSocketTalk = class;

  TMessageSize = array of Integer;

  TSessionState = (stNone, stProxy, stConnect, stUser, stPass, stStat, stList, stRetr, stDele, stHelo, stMail, stRcpt, stData, stSendData, stQuit);
  TTalkError = (teGeneral, teSend, teReceive, teConnect, teDisconnect, teAccept, teTimeout, teNoError);

  TProgressEvent = procedure(Sender: TObject; Total, Current: Integer) of object;
  TEndOfDataEvent = procedure(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean) of object;
  TSocketTalkErrorEvent = procedure(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError) of object;
  TReceiveDataEvent = procedure(Sender: TObject; Sessionstate: TSessionState; Data: String; var ServerResult: Boolean) of object;

  TReceivedField = (reFrom, reBy, reFor, reDate, reNone);

  TReceived = record
    From: String;
    By: String;
    Address: String;
    Date: TDateTime;
  end;

  { TMailPart - A recursive class to handle parts, subparts, and the mail by itself }

  TMailPart = class(TComponent)
  private

    FHeader: TStringList {TMailText};
    FBody: TMemoryStream;
    FDecoded: TMemoryStream;
    FBoundary: String;
    FOwnerMessage: TMailMessage2000;
    FSubPartList: TMailPartList;
    FOwnerPart: TMailPart;
    FAttachedMessage: TMailMessage2000;
    FIsDecoded: Boolean;

    function GetAttachInfo: String;
    function GetFileName: String;

    procedure SetAttachInfo(AttachInfo: String);
    procedure SetFileName(FileName: String);

    procedure EncodeText;
    procedure EncodeBinary;

  public

    constructor Create(AOwner: TComponent); override;
		destructor Destroy; override;

    function GetLabelValue(cLabel: String): String;                           // Get the value of a label. e.g. Label: value
    function GetLabelParamValue(cLabel, Param: String): String;               // Get the value of a label parameter. e.g. Label: xxx; param=value
    function LabelExists(cLabel: String): Boolean;                            // Determine if a label exists
    function LabelParamExists(cLabel, Param: String): Boolean;                // Determine if a label parameter exists

    function Decode: Boolean;                                                 // Decode body in Decoded stream and result true if successful

    procedure SetLabelValue(cLabel, cValue: String);                          // Set the value of a label
    procedure SetLabelParamValue(cLabel, cParam, cValue: String);             // Set the value of a label parameter

    procedure Fill(Data: PChar; HasHeader: Boolean);                          // Store the data on mail part (divide body, header, determine subparts)
    procedure Remove;                                                         // Delete this mailpart from message

    procedure LoadFromFile(FileName: String);                                 // Load the data from a file
    procedure SaveToFile(FileName: String);                                   // Save the data to a file

    property Header: TStringList {TMailText} read FHeader;                    // The header text
    property Body: TMemoryStream read FBody;                                  // The original body
    property Decoded: TMemoryStream read FDecoded;                            // Stream with the body decoded
    property Boundary: String read FBoundary;                                 // String that divides this mail part from others
    property SubPartList: TMailPartList read FSubPartList;                    // List of subparts of this mail part
    property FileName: String read GetFileName write SetFileName;             // Name of file when this mail part is an attached file
    property AttachInfo: String read GetAttachInfo write SetAttachInfo;       // E.g. application/octet-stream
    property OwnerMessage: TMailMessage2000 read FOwnerMessage;               // Main message that owns this mail part
    property OwnerPart: TMailPart read FOwnerPart;                            // Father part of this part (can be the main message too)
    property AttachedMessage: TMailMessage2000 read FAttachedMessage;         // If this part is a message/rfc822, here is the message (need Decode)
    property IsDecoded: Boolean read FIsDecoded;                              // If this part is decoded
  end;

  { TMailPartList - Just a collection of TMailPart's }

	TMailPartList = class(TList)
	private

		function Get(const Index: Integer): TMailPart;

	public

		destructor Destroy; override;

		property Items[const Index: Integer]: TMailPart read Get; default;
	end;

  { TMailMessage2000 - A descendant of TMailPart with some tools to handle the mail }

  TMailMessage2000 = class(TMailPart)
  private

    FAttachList: TMailPartList;
    FTextPlain: TStringList;
    FTextHTML: TStringList;
    FTextPart: TMailPart;
    FTextPlainPart: TMailPart;
    FTextHTMLPart: TMailPart;
    FCharset: String;
    FOnProgress: TProgressEvent;
    FNameCount: Integer;
    FToNames: TStringList;
    FToAddresses: TStringList;
    FCcNames: TStringList;
    FCcAddresses: TStringList;

    FNeedRebuild: Boolean;

    function GetDestName(Field: String; const Index: Integer): String;
    function GetDestAddress(Field: String; const Index: Integer): String;
    function GetDestCount(Field: String): Integer;

    function GetReceivedCount: Integer;
    function GetReceived(const Index: Integer): TReceived;

    function GetToName(const Index: Integer): String;
    function GetToAddress(const Index: Integer): String;
    function GetToCount: Integer;
    function GetCcName(const Index: Integer): String;
    function GetCcAddress(const Index: Integer): String;
    function GetCcCount: Integer;
    function GetBccName(const Index: Integer): String;
    function GetBccAddress(const Index: Integer): String;
    function GetBccCount: Integer;

    function GetFromName: String;
    function GetFromAddress: String;
    function GetReplyToName: String;
    function GetReplyToAddress: String;
    function GetSubject: String;
    function GetDate: TDateTime;
    function GetMessageId: String;

    procedure AddDest(Field, Name, Address: String);
    procedure SetDest(Field, Names, Addresses: String);

    procedure PutText(Text: String; Part: TMailPart; Content: String);

    procedure SetSubject(Subject: String);
    procedure SetDate(Date: TDateTime);
    procedure SetMessageId(MessageId: String);

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure AddTo(Name, Address: String);                                   // Add a To: destination to message header
    procedure AddCc(Name, Address: String);                                   // Add a Cc: destination to message header
    procedure AddBcc(Name, Address: String);                                  // Add a Bcc: destination to message header

    procedure SetTo(Names, Addresses: String);                                // Set To: destinations in commatext format
    procedure SetCc(Names, Addresses: String);                                // Set Cc: destinations in commatext format
    procedure SetBcc(Names, Addresses: String);                               // Set Bcc: destinations in commatext format

    procedure ClearTo;                                                        // Delete the To: field
    procedure ClearCc;                                                        // Delete the Cc: field
    procedure ClearBcc;                                                       // Delete the Bcc: field

    procedure SetFrom(Name, Address: String);                                 // Create/modify the From: field
    procedure SetReplyTo(Name, Address: String);                              // Create/modify the Reply-To: field

    procedure GetAttachList;                                                  // Search for the attachments and text
    procedure RebuildBody;                                                    // Build the mail body according to mailparts
    procedure Reset;                                                          // Clear all stored data in the object
    procedure AttachFile(FileName: String; ContentType: String = '');         // Create a mailpart and encode a file on it (doesn't rebuild body)
    procedure SetTextPlain(Text: TStrings);                                   // Create/modify a mailpart for text/plain (doesn't rebuild body)
    procedure SetTextHTML(Text: TStrings);                                    // Create/modify a mailpart for text/html (doesn't rebuild body)
    procedure RemoveTextPlain;                                                // Remove the first text/plain mailpart (doesn't rebuild body)
    procedure RemoveTextHTML;                                                 // Remove the first text/html mailpart (doesn't rebuild body)

    property ToName[const Index: Integer]: String read GetToName;             // Retrieve the name of To: destination number # (first is zero)
    property ToAddress[const Index: Integer]: String read GetToAddress;       // Retrieve the address of To: destination number #
    property ToCount: Integer read GetToCount;                                // Count the number of To: destinations
    property CcName[const Index: Integer]: String read GetCcName;             // Retrieve the name of Cc: destination number #
    property CcAddress[const Index: Integer]: String read GetCcAddress;       // Retrieve the address of Cc: destination number #
    property CcCount: Integer read GetCcCount;                                // Count the number of Cc: destinations
    property BccName[const Index: Integer]: String read GetBccName;           // Retrieve the name of Bcc: destination number #
    property BccAddress[const Index: Integer]: String read GetBccAddress;     // Retrieve the address of Bcc: destination number #
    property BccCount: Integer read GetBccCount;                              // Count the number of Bcc: destinations
    property Received[const Index: Integer]: TReceived read GetReceived;      // Retrieve the n-th 'Received' header
    property ReceivedCount: Integer read GetReceivedCount;                    // Count the instances of 'Received' fields (hops)
    property ToNames: TStringList read FToNames;                              // Names of To: destinations filled in a StringList (readonly! need GetAttachList)
    property CcNames: TStringList read FCcNames;                              // Names of Cc: destinations filled in a StringList (readonly! need GetAttachList)
    property ToAddresses: TStringList read FToAddresses;                      // Addresses of To: destinations filled in a StringList (readonly! need GetAttachList)
    property CcAddresses: TStringList read FCcAddresses;                      // Addresses of Cc: destinations filled in a StringList (readonly! need GetAttachList)

    property FromName: String read GetFromName;                               // Retrieve the From: name
    property FromAddress: String read GetFromAddress;                         // Retrieve the From: address
    property ReplyToName: String read GetReplyToName;                         // Retrieve the Reply-To: name
    property ReplyToAddress: String read GetReplyToAddress;                   // Retrieve the Reply-To: address
    property Subject: String read GetSubject write SetSubject;                // Retrieve or set the Subject: string
    property Date: TDateTime read GetDate write SetDate;                      // Retrieve or set the Date: in TDateTime format
    property MessageId: String read GetMessageId write SetMessageId;          // Retrieve or set the Message-Id:
    property AttachList: TMailPartList read FAttachList;                      // A list of all attached files (need GetAttachList)
    property TextPlain: TStringList read FTextPlain;                          // A StringList with the text/plain from message (need GetAttachList)
    property TextHTML: TStringList read FTextHTML;                            // A StringList with the text/html from message (need GetAttachList)
    property TextPlainPart: TMailPart read FTextPlainPart;                    // The text/plain part
    property TextHTMLPart: TMailPart read FTextHTMLPart;                      // The text/html part
    property NeedRebuild: Boolean read FNeedRebuild;                          // True if RebuildBody is needed

  published

    property Charset: String read FCharSet write FCharset;                    // Charset to build headers and text (allways 7bit)
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;   // Occurs when storing message in memory
  end;

  { TSocketTalk }

  TSocketTalk = class(TComponent)
  private

    FTimeOut: Integer;
    FExpectedEnd: String;
    FLastResponse: String;
    FDataSize: Integer;
    FPacketSize: Integer;
    FTalkError: TTalkError;
    FSessionState: TSessionState;
    FClientSocket: TClientSocket;
    FWaitingServer: Boolean;
    FTimer: TTimer;
    FServerResult: Boolean;

    FOnProgress: TProgressEvent;
    FOnEndOfData: TEndOfDataEvent;
    FOnSocketTalkError: TSocketTalkErrorEvent;
    FOnReceiveData: TReceiveDataEvent;
    FOnDisconnect: TNotifyEvent;

    procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure Timer(Sender: TObject);
  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Talk(Buffer, EndStr: String; SessionState: TSessionState);
    procedure Cancel;
    procedure ForceState(SessionState: TSessionState);
    procedure WaitServer;

    property LastResponse: String read FLastResponse;
    property DataSize: Integer read FDataSize write FDataSize;
    property PacketSize: Integer read FPacketSize write FPacketSize;
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property TalkError: TTalkError read FTalkError;
    property ClientSocket: TClientSocket read FClientSocket;
    property ServerResult: Boolean read FServerResult;

    property OnEndOfData: TEndOfDataEvent read FOnEndOfData write FOnEndOfData;
    property OnSocketTalkError: TSocketTalkErrorEvent read FOnSocketTalkError write FOnSocketTalkError;
    property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
  end;

  { TPOP2000 }

  TPOP2000 = class(TComponent)
  private

    FMailMessage: TMailMessage2000;

    FSessionMessageCount: Integer;
    FSessionMessageSize: TMessageSize;
    FSessionConnected: Boolean;
    FSessionLogged: Boolean;
    FLastMessage: String;
    FSocketTalk: TSocketTalk;

    FUserName: String;
    FPassword: String;
    FPort: Integer;
    FHost: String;
    FProxyPort: Integer;
    FProxyHost: String;
    FProxyUsage: Boolean;
    FProxyString: String;
    FDeleteOnRetrieve: Boolean;

    procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
    procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketDisconnect(Sender: TObject);

    function GetTimeOut: Integer;
    procedure SetTimeOut(Value: Integer);

    function GetProgress: TProgressEvent;
    procedure SetProgress(Value: TProgressEvent);

    function GetLastResponse: String;

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect: Boolean;                                                // Connect to mail server
    function Login: Boolean;                                                  // Autenticate to mail server
    function Quit: Boolean;                                                   // Logout and disconnect

    function RetrieveMessage(Number: Integer): Boolean;                       // Retrieve mail number # and put in MailMessage
    function RetrieveHeader(Number: Integer): Boolean;
    function DeleteMessage(Number: Integer): Boolean;                         // Delete mail number #

    property SessionMessageCount: Integer read FSessionMessageCount;          // Number of messages found on server
    property SessionMessageSize: TMessageSize read FSessionMessageSize;       // Dynamic array with size of the messages
    property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
    property SessionLogged: Boolean read FSessionLogged;                      // True if autenticated on server
    property LastMessage: String read FLastMessage;                           // Last integral message text
    property LastResponse: String read GetLastResponse;                       // Last string received from server

  published

    property UserName: String read FUserName write FUserName;                 // User name to login on server
    property Password: String read FPassword write FPassword;                 // Password
    property Port: Integer read FPort write FPort;                            // Port (usualy 110)
    property Host: String read FHost write FHost;                             // Host address
    property ProxyPort: Integer read FProxyPort write FProxyPort;             // Port to connect on proxy server
    property ProxyHost: String read FProxyHost write FProxyHost;              // Address of proxy server
    property ProxyUsage: Boolean read FProxyUsage write FProxyUsage;          // True when using a proxy server to get mail
    property ProxyString: String read FProxyString write FProxyString;        // String to inform proxy server where to connect (%h% Host, %p% Port, %u% User)
    property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message retrieved
    property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for server reply in seconds
    property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when receiving data from server
    property DeleteOnRetrieve: Boolean read FDeleteOnRetrieve write FDeleteOnRetrieve;  // If message will be deleted after successful retrieve
  end;

  { TSMTP2000 }

  TSMTP2000 = class(TComponent)
  private

    FMailMessage: TMailMessage2000;

    FSessionConnected: Boolean;
    FSocketTalk: TSocketTalk;
    FPacketSize: Integer;

    FPort: Integer;
    FHost: String;
    FProxyPort: Integer;
    FProxyHost: String;
    FProxyUsage: Boolean;
    FProxyString: String;

    procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
    procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketDisconnect(Sender: TObject);

    function GetTimeOut: Integer;
    procedure SetTimeOut(Value: Integer);

    function GetProgress: TProgressEvent;
    procedure SetProgress(Value: TProgressEvent);

    function GetLastResponse: String;

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect: Boolean;                                                // Connect to mail server
    function Quit: Boolean;                                                   // Disconnect

    function SendMessage: Boolean;                                            // Send MailMessage to server

    property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
    property LastResponse: String read GetLastResponse;                       // Last string received from server

  published

    property Port: Integer read FPort write FPort;                            // Port (usualy 25)
    property Host: String read FHost write FHost;                             // Host address
    property ProxyPort: Integer read FProxyPort write FProxyPort;             // Port to connect on proxy server
    property ProxyHost: String read FProxyHost write FProxyHost;              // Address of proxy server
    property ProxyUsage: Boolean read FProxyUsage write FProxyUsage;          // True when using a proxy server to send mail
    property ProxyString: String read FProxyString write FProxyString;        // String to inform proxy server where to connect (%h% Host, %p% Port)
    property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for a response in seconds
    property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message to send
    property PacketSize: Integer read FPacketSize write FPacketSize;          // Size of packets to send to server
    property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when sending data to server
  end;

procedure Register;

{ Very useful functions ====================================================== }

function DecodeLine7Bit(Texto: String): String; forward;
function EncodeLine7Bit(Texto, Charset: String): String; forward;
function DecodeQuotedPrintable(Texto: String): String; forward;
function EncodeQuotedPrintable(Texto: String; HeaderLine: Boolean): String; forward;
function DecodeUUCODE(Encoded: PChar; Decoded: TMemoryStream): Boolean; forward;
function DecodeLineUUCODE(const Buffer: String; Decoded: PChar): Integer; forward;
function DecodeLineBASE64(const Buffer: String; Decoded: PChar): Integer; forward;
function EncodeBASE64(Encoded: TMemoryStream {TMailText}; Decoded: TMemoryStream): Integer; forward;
function NormalizeLabel(Texto: String): String; forward;
function LabelValue(cLabel: String): String; forward;
function WriteLabelValue(cLabel, Value: String): String; forward;
function LabelParamValue(cLabel, cParam: String): String; forward;
function WriteLabelParamValue(cLabel, cParam, Value: String): String; forward;
function GetTimeZoneBias: Double; forward;
function PadL(Str: String; Tam: Integer; PadStr: String): String; forward;
function GetMimeType(FileName: String): String; forward;
function GetMimeExtension(MimeType: String): String; forward;
function GenerateBoundary: String; forward;
function SearchStringList(Lista: TStringList; Chave: String; Occorrence: Integer = 0): Integer; forward;
procedure DataLine(var Data, Line: String; var nPos: Integer); forward;
procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); forward;
procedure WrapSL(Source: TStringList; var Dest: String; Margin: Integer); forward;
function IsIPAddress(SS: String): Boolean; forward;
function FindReplace(Source, Old, New: String): String; forward;
function TrimSpace(const S: string): string; forward;
function TrimLeftSpace(const S: string): string; forward;
function TrimRightSpace(const S: string): string; forward;
function MailDateToDelphiDate(const DateStr: String): TDateTime; forward;
function ValidFileName(FileName: String): String;

implementation

const
  _C_T  = 'Content-Type';
  _C_D  = 'Content-Disposition';
  _C_TE = 'Content-Transfer-Encoding';
  _C_ID = 'Content-ID';


procedure Register;
begin

  RegisterComponents('Mail2000', [TPOP2000, TSMTP2000, TMailMessage2000]);
end;

// Decode an encoded field e.g. =?iso-8859-1?x?xxxxxx=?=

function DecodeLine7Bit(Texto: String): String;
var
  Buffer: PChar;
  Encoding: Char;
  Size: Integer;
  nPos0: Integer;
  nPos1: Integer;
  nPos2: Integer;
  nPos3: Integer;
  Found: Boolean;

begin

  Result := TrimSpace(Texto);

  repeat

    nPos0 := Pos('=?', Result);
    Found := False;

    if nPos0 > 0 then
    begin

      nPos1 := Pos('?', Copy(Result, nPos0+2, Length(Result)))+nPos0+1;
      nPos2 := Pos('?=', Copy(Result, nPos1+1, Length(Result)))+nPos1;
      nPos3 := Pos('?', Copy(Result, nPos2+1, Length(Result)))+nPos2;

      if nPos3 > nPos2 then
      begin

        if Length(Result) > nPos3 then
        begin

          if Result[nPos3+1] = '=' then
          begin

            nPos2 := nPos3;
          end;
        end;
      end;

      if (nPos1 > nPos0) and (nPos2 > nPos1) then
      begin