nmpop3.pas

DELPHI里面一些常用的控件

unit NMpop3;
{$X+}
{$R-}

{$IFDEF VER100}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER110}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER120}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER125}
{$DEFINE NMF3}
{$ENDIF}

interface

uses
  Classes, PSock, Sysutils, NMUUE, NMExtstr, NMConst;
{$IFDEF VER110}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER120}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER125}
{$OBJEXPORTALL On}
{$ENDIF}

const
  POP3_PORT = 110;

   //  CompName     ='NMPOP3';
   //  Major_Version='4';
   //  Minor_Version='02';
   //  Date_Version ='012798';

const {Protocol}
  Cons_OK_Resp = '+OK';
  Cons_Err_Resp = '-ERR';
  Cons_Cmd_User = 'USER ';
  Cons_Cmd_Pass = 'PASS ';
  Cons_Cmd_Stat = 'STAT';
  Cons_Cmd_Quit = 'QUIT';
  Cons_Cmd_Top = 'TOP ';
  Cons_Cmd_List = 'LIST ';
  Cons_Cmd_Retr = 'RETR ';
  Cons_Cmd_Dele = 'DELE ';
  Cons_Cmd_Rset = 'RSET';
  Cons_Cmd_Uidl = 'UIDL ';
  Cons_Head_CSubj = 'SUBJECT:';
  Cons_Head_CFrom = 'FROM:';
  Cons_Head_CType = 'CONTENT-TYPE:';
  Cons_Head_CMid = 'MESSAGE-ID:';
  Cons_Head_CBoun = 'BOUNDARY=';
  Cons_Head_CCTE = 'CONTENT-TRANSFER-ENCODING';
  Cons_Head_FileN = 'FILENAME';
  Cons_Head_Subj = 'Subject:';
  Cons_Head_From = 'From:';
  Cons_Head_MId = 'Message-ID:';
  Cons_Head_Mult = 'multipart';
  Cons_Head_UUEn = 'X-UUENCODE';
  Cons_Head_B641 = 'base64';
  Cons_Head_B642 = 'Base64';

type
  TListEvent = procedure(Msg, Size: integer) of object;
      // Modification made by Edward T. Smith Sep 09 1998
  TVarFileNameEvent = procedure(var FileName: string) of object;
      // End

  TMailMessage = class(TPersistent)
  private
    FHead: TexStringList;
    FRawBody: TStringList;
    FBody: TStringList;
    Fcontenttypes, FAttachments: TStringList;
    FPartHeaders: TList;
    FContentType: string;
    FFrom: string;
    FSubject: string;
    FMessageId: string;

  public
    FBoundary: string;
    constructor Create;
    destructor Destroy; override;
    property Subject: string read FSubject;
    property From: string read FFrom;
    property RawBody: TStringList read FRawBody;
    property Body: TStringList read FBody;
    property Head: TExStringList read FHead;
    property MessageId: string read FMessageId write FMessageId;
    property ContentType: string read FContentType write FContentType;
    property Attachments: TStringList read FAttachments;
    property AttachContenttypes: TStringList read FContentTypes;
    property PartHeaders: TList read FPartHeaders;
  end; {_ TMailMessage      = class(TPersistent) _}

  TSummary = class(TPersistent)
  private
    FSubject: string;
    FFrom: string;
    FBytes: integer;
    FMessageId: string;
    FHeader: TExStringList;
  published
    constructor Create;
    destructor Destroy; override;
    property Subject: string read FSubject write FSubject;
    property From: string read FFrom write FFrom;
    property MessageId: string read FMessageId write FMessageId;
    property Bytes: integer read FBytes write FBytes;
    property Header: TExStringList read FHeader write FHeader;
  end; {_ TSummary          = class(TPersistent) _}

  TNMPOP3 = class(TPowerSock)
  private
      // Modification made by Edward T. Smith Sep 09 1998
    FOnDecodeStart: TVarFileNameEvent;
    FOnDecodeEnd: TNotifyEvent;
      // End
    NMUUProcessor1: TNMUUProcessor;
    FAttachFilePath, FFilename, FContent_type: string;
    FSummary: TSummary;
    FParse: boolean;
    FMailMessage: TMailMessage;
    FUserID, FPassword: string;
    FAbort, FDeleteOnRead, FTransactionInProgress: boolean;
    FMailCount, FFirstPart: integer;
    FOnAuthenticationNeeded: THandlerEvent;
    FOnAuthenticationFailed: THandlerEvent;
    FOnReset: TNotifyEvent;
    FOnList: TListEvent;
    FOnRetrieveStart: TNotifyEvent;
    FOnRetrieveEnd: TNotifyEvent;
    FOnSuccess: TNotifyEvent;
    FOnFailure: TNotifyEvent;
    FOnConnect: TNotifyEvent;
    WaitForReset: integer;
    procedure ReadMailParts;
    function ReadBody(var MailMessage: TMailMessage): boolean;
    procedure ReadHeader(Readfile: boolean; var MailMessage: TMailMessage);
    procedure AbortResume(Sender: TObject);
    procedure SetAttachFilePath(Value: string);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect; override;
    procedure Disconnect; override;
    procedure GetMailMessage(MailNumber: integer);
    procedure GetSummary(MailNumber: integer);
    procedure DeleteMailMessage(MailNumber: integer);
    procedure Extract(InString: string; var OutString: string);
    function UniqueID(MailNumber: integer): string;
    procedure Reset;
    procedure List;
    procedure Abort; override;
    property MailCount: integer read FMailCount;
    property Summary: TSummary read FSummary;
    property MailMessage: TMailMessage read FMailMessage;
    property OnRetriveStart: TNotifyEvent read FOnRetrieveStart write FOnRetrieveStart;
    property OnRetriveEnd: TNotifyEvent read FOnRetrieveEnd write FOnRetrieveEnd;

  published
    property OnConnectionRequired;
    property OnPacketRecvd;
    property BytesRecvd;
    property BytesTotal;
    property UserID: string read FUserID write FUserID;
    property Parse: boolean read FParse write FParse;
    property Password: string read FPassword write FPassword;
    property DeleteOnRead: boolean read FDeleteOnRead write FDeleteOnRead;
      // Modification made by Edward T. Smith Sep 09 1998
    property AttachFilePath: string read FAttachFilePath write SetAttachFilePath;
      // End
    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property OnAuthenticationNeeded: THandlerEvent read FOnAuthenticationNeeded write FOnAuthenticationNeeded;
    property OnAuthenticationFailed: THandlerEvent read FOnAuthenticationFailed write FOnAuthenticationFailed;
    property OnReset: TNotifyEvent read FOnReset write FOnReset;
    property OnList: TListEvent read FOnList write FOnList;
    property OnRetrieveStart: TNotifyEvent read FOnRetrieveStart write FOnRetrieveStart;
    property OnRetrieveEnd: TNotifyEvent read FOnRetrieveEnd write FOnRetrieveEnd;
    property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
    property OnFailure: TNotifyEvent read FOnFailure write FOnFailure;
      // Modification made by Edward T. Smith Sep 09 1998
    property OnDecodeStart: TVarFileNameEvent read FOnDecodeStart write FOnDecodeStart;
    property OnDecodeEnd: TNotifyEvent read FOnDecodeEnd write FOnDecodeEnd;
      // End
  end; {_ TNMPOP3           = class(TPowerSock) _}

implementation
var Readindex, TFileIndex: integer;

constructor TSummary.Create;
begin
  inherited Create;
  FHeader := TExStringList.Create;
end;

destructor TSummary.Destroy;
begin
  FHeader.Free;
  inherited Destroy;
end;

procedure TNMPOP3.SetAttachFilePath(Value: string);
begin
  if Value[Length(Value)] <> '\' then
    Value := Value + '\';
  FAttachFilePath := Value;
end;
// End

constructor TNMPOP3.Create(AOwner: TComponent);
 begin
  inherited Create(AOwner);
  Port := POP3_Port;
  FMailMessage := TMailMessage.create;
  FSummary := TSummary.create;
  FDeleteOnRead := FALSE;
  FTransactionInProgress := FALSE;
  FAttachFilePath := '';
  OnAbortRestart := AbortResume;
  WaitForReset := 2;
  NMUUProcessor1 := TNMUUProcessor.create(self);
end; {_ constructor TNMPOP3.Create(AOwner: TComponent); _}


destructor TNMPOP3.Destroy;
begin
  FSummary.free;
  FMailMessage.free;
  NMUUProcessor1.free;
  inherited Destroy;
end; {_ destructor TNMPOP3.Destroy; _}



procedure TNMPOP3.Connect;
var
  ReplyMess: string;
  Check: boolean;
  TryCt: integer;
  Done, ConnCalled, Handled: boolean;

  function CheckAuth(FromHost: string): boolean;
  begin
    if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) > 0 then Result := TRUE
    else {_ NOT if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) > 0 then Result := TRUE _}
      begin
        Result := FALSE;
        if TryCt > 0 then raise Exception.create(Cons_Msg_Auth_Fail)
        else {_ NOT if TryCt > 0 then raise Exception.create(Cons_Msg_Auth_Fail) _}
          if not assigned(FOnAuthenticationFailed) then
            raise Exception.create(Cons_Msg_Auth_Fail)
          else {_ NOT if not assigned(FOnAuthenticationFailed) then raise Exception.create(Cons_Msg_Auth_Fail) _}
            begin
              Handled := FALSE;
              FOnAuthenticationFailed(Handled);
              if not Handled then raise Exception.create(Cons_Msg_Auth_Fail);
              TryCt := TryCt + 1;
            end; {_ NOT if not assigned(FOnAuthenticationFailed) then raise Exception.create(Cons_Msg_Auth_Fail) _}
      end; {_ NOT if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) > 0 then Result := TRUE _}
  end; {_ function CheckAuth(FromHost: string): boolean; _}

begin
  Done := FALSE;
  TryCt := 0;
  while (Password = '') or (UserID = '') do
    if not assigned(FOnAuthenticationNeeded) then raise Exception.create(Cons_Msg_Auth_Fail)
    else {_ NOT if not assigned(FOnAuthenticationNeeded) then raise Exception.create(Cons_Msg_Auth_Fail) _}
      begin
        if TryCt > 0 then break;
        handled := FALSE;
        FOnAuthenticationNeeded(Handled);
        if not handled then raise Exception.create(Cons_Msg_Auth_Fail);
        inc(TryCt);
      end; {_ NOT if not assigned(FOnAuthenticationNeeded) then raise Exception.create(Cons_Msg_Auth_Fail) _}
  ConnCalled := FALSE;
  if FTransactionInProgress then ConnCalled := TRUE else FTransactionInProgress := TRUE;
  try
    inherited Connect;
    try
      ReplyMess := ReadLn;
      if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) = 0 then raise Exception.create(ReplyMess);
      Check := FALSE; TryCt := 0;
      while not check do
        begin
          ReplyMess := Transaction(Cons_Cmd_User + FUserID);
          if CheckAuth(ReplyMess) then
            begin
              ReplyMess := Transaction(Cons_Cmd_Pass + FPassword);
              Check := CheckAuth(ReplyMess)
            end; {_ if CheckAuth(ReplyMess) then _}
          TryCt := TryCt + 1;
        end; {_ while not check do _}
      Done := TRUE;
      ReplyMess := Transaction(Cons_Cmd_Stat);
      if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) = 0 then raise Exception.create(ReplyMess);
      FMailCount := StrToIntDef(NthWord(ReplyMess, ' ', 2), 0);
    except
      Disconnect;
      raise
    end; {_ try _}
  finally
    if not ConnCalled then FTransactionInProgress := FALSE;
    if Done then
      if assigned(FOnConnect) then
        FOnConnect(self);
  end; {_ try _}
end; {_ procedure TNMPOP3.Connect; _}

procedure TNMPOP3.Disconnect;
var ReplyMess: string;
begin
  if Connected then
    try
      ReplyMess := Transaction(Cons_Cmd_Quit);
      if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) = 0 then raise Exception.create(ReplyMess);
    finally
      inherited Disconnect;
    end; {_ try _}
end; {_ procedure TNMPOP3.Disconnect; _}

procedure TNMPOP3.GetSummary(MailNumber: integer);
var ReplyMess: string;
begin
  if not FTransactionInProgress then
    begin
      FTransactionInProgress := TRUE;
      try
        CertifyConnect;
        if assigned(FOnRetrieveStart) then FOnRetrieveStart(self);
        FAbort := FALSE;
        ReplyMess := Transaction(Cons_Cmd_Top + IntToStr(MailNumber) + ' 0');
        if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) = 0 then raise Exception.create(ReplyMess);
        FSummary.FHeader.clear;
        FSummary.FSubject := '';
        FSummary.FFrom := '';
        FSummary.FMessageID := '';
        if not FAbort then
          repeat
            ReplyMess := readln;
            if Pos(Cons_Head_Subj, ReplyMess) = 1 then FSummary.FSubject := Copy(ReplyMess, 9, length(ReplyMess) - 10);
            if Pos(Cons_Head_From, ReplyMess) = 1 then FSummary.FFrom := Copy(ReplyMess, 6, length(ReplyMess) - 7);
            if Pos(Cons_Head_MId, ReplyMess) = 1 then FSummary.FMessageID := Copy(ReplyMess, 13, 256);
            if Replymess[Length(Replymess) - 1] = #13 then
              SetLength(Replymess, Length(Replymess) - 2)
            else {_ NOT if Replymess[Length(Replymess) - 1] = #13 then _}  SetLength(Replymess, Length(Replymess) - 1);
            FSummary.FHeader.add(ReplyMess);
          until ReplyMess = '.';
        ReplyMess := Transaction(Cons_Cmd_List + IntToStr(MailNumber));
        FSummary.FBytes := StrToInt(Trim(NthWord(ReplyMess, ' ', 3)));
        StatusMessage(Status_Informational, sPOP_Cons_Summ_Retr);
        if assigned(FOnRetrieveEnd) then FOnRetrieveEnd(self);
      finally
        FTransactionInProgress := FALSE;
      end; {_ try _}
    end; {_ if not FTransactionInProgress then _}
end; {_ procedure TNMPOP3.GetSummary(MailNumber: integer); _}

procedure TNMPOP3.GetMailMessage(MailNumber: integer);
var ReplyMess: string;
begin
  if not FTransactionInProgress then
    begin
      FTransactionInProgress := TRUE;
      CertifyConnect;
      if assigned(FOnRetrieveStart) then FOnRetrieveStart(self);
      try
        FContent_type := '';
        FMailMessage.FBoundary := '';
        FFilename := '';
        FAbort := FALSE;