 | 
|
|
|
{ }
{ POP3 Client v3.03 }
{ }
{ This unit is copyright © 2000-2004 by David J Butler }
{ }
{ This unit is part of Delphi Fundamentals. }
{ Its original file name is cPOP3Client.pas }
{ The latest version is available from the Fundamentals home page }
{ http://fundementals.sourceforge.net/ }
{ }
{ I invite you to use this unit, free of charge. }
{ I invite you to distibute this unit, but it must be for free. }
{ I also invite you to contribute to its development, }
{ but do not distribute a modified copy of this file. }
{ }
{ A forum is available on SourceForge for general discussion }
{ http://sourceforge.net/forum/forum.php?forum_id=2117 }
{ }
{ }
{ Revision history: }
{ 2000/06/21 0.01 Initial version of TPOP3Client. }
{ 2002/09/09 0.02 Refactored. }
{ 2004/02/06 3.03 Included in Fundamentals 3. }
{ }
{$INCLUDE ..\cDefines.inc}
unit cPOP3Client;
interface
uses
{ Delphi }
SysUtils,
{ Fundamentals }
cUtils,
cStreams,
cInternetUtils,
cTCPStream,
cTCPClient,
cPOP3;
{ }
{ TPOP3Client }
{ }
type
EPOP3Client = class(Exception);
TPOP3Client = class;
TPOP3ClientEvent = procedure (Sender: TPOP3Client) of object;
TPOP3StatusEvent = procedure (Sender: TPOP3Client; Msg: String) of object;
TPOP3ClientAction = (
pcaNone,
pcaConnect,
pcaLogIn,
pcaMailboxStats);
TPOP3Client = class(ATCPClient)
protected
FAction : TPOP3ClientAction;
FStatusMsg : String;
FOnStatus : TPOP3StatusEvent;
FOnSyncStatus : TPOP3StatusEvent;
FOnLoggedIn : TPOP3ClientEvent;
FOnMailboxStats : TPOP3ClientEvent;
FOnComplete : TPOP3ClientEvent;
FOnSyncComplete : TPOP3ClientEvent;
{ Server Greeting }
FServerReady : Boolean;
FWelcomeMsg : String;
{ Authentication }
FAPOPStamp : String;
FDisableAPOP : Boolean;
FUsername : String;
FPassword : String;
FLoggedIn : Boolean;
{ Stats }
FStatsUpToDate : Boolean;
FMessageCount : Integer;
FTotalSize : Int64;
{ Capabilities }
FSentCAPA : Boolean;
FCAPAFailed : Boolean;
FCapaUIDL : Boolean;
FCapaTOP : Boolean;
FCapaUSER : Boolean;
procedure Init; override;
{ Session }
procedure SetAction(const Action: TPOP3ClientAction);
procedure ThreadRun; override;
procedure NotifyStatus; virtual;
procedure NotifyComplete; virtual;
procedure TriggerLoggedIn; virtual;
procedure TriggerMailboxStats; virtual;
procedure TriggerComplete; virtual;
{ Command / Response }
function GetResponse(var Msg: String): Boolean;
function GetMultiLineLine: String;
procedure StatusMessage(const Msg: String);
procedure SendCommand(const S: String);
function Readln: String;
{ Server Greeting }
function GetWelcomeMsg: String;
function GetServerReady: Boolean;
{ Capabilities }
procedure GetCapabilities;
function GetCapaUIDL: Boolean;
function GetCapaTOP: Boolean;
function GetCapaUSER: Boolean;
function GetHaveServerCapabilities: Boolean;
{ Authentication }
function GetAPOPSupported: Boolean;
procedure Login(const UserName, Password: String);
procedure APOPLogin(const UserName, Password: String);
procedure Logout;
procedure SetLoggedIn(const LoggedIn: Boolean);
procedure SetUsername(const Username: String);
procedure SetPassword(const Password: String);
{ Stats }
procedure GetStats;
function GetMessageCount: Integer;
function GetTotalSize: Int64;
public
property Action: TPOP3ClientAction read FAction write SetAction default pcaNone;
{ Server Greeting }
property WelcomeMsg: String read GetWelcomeMsg;
property ServerReady: Boolean read GetServerReady;
{ Capabilities }
property HaveServerCapabilities: Boolean read GetHaveServerCapabilities;
property ServerSupportUIDs: Boolean read GetCapaUIDL;
property ServerSupportMessageHeaders: Boolean read GetCapaTOP;
property ServerSupportUserPassLogin: Boolean read GetCapaUSER;
{ Authentication }
property Username: String read FUsername write SetUsername;
property Password: String read FPassword write SetPassword;
property DisableAPOP: Boolean read FDisableAPOP write FDisableAPOP default False;
property APOPSupported: Boolean read GetAPOPSupported;
property LoggedIn: Boolean read FLoggedIn write SetLoggedIn;
{ Stats }
property MessageCount: Integer read GetMessageCount;
property TotalSize: Int64 read GetTotalSize;
{ Messages }
function GetMessageSizes(var MsgNrs: IntegerArray): Int64Array;
function GetMessageSize(const MsgNr: Integer): Int64;
function GetMessageUID(const MsgNr: Integer): String;
function GetMessageUIDs(var MsgNrs: IntegerArray): StringArray;
function GetMessageHeader(const MsgNr: Integer;
const PreviewLines: Integer; var Preview: String): THeader;
function GetMessageHeaders(const MsgNrs: IntegerArray;
const PreviewLines: Integer; var Previews: StringArray): THeaderArray;
function GetMessage(const MsgNr: Integer): String; overload;
procedure GetMessage(const MsgNr: Integer;
var Hdr: String; const MessageBody: AStream); overload;
procedure DeleteMessage(const MsgNr: Integer);
{ Events }
property OnStatus: TPOP3StatusEvent read FOnStatus write FOnStatus;
property OnSyncStatus: TPOP3StatusEvent read FOnSyncStatus write FOnSyncStatus;
property OnLoggedIn: TPOP3ClientEvent read FOnLoggedIn write FOnLoggedIn;
property OnMailboxStats: TPOP3ClientEvent read FOnMailboxStats write FOnMailboxStats;
property OnComplete: TPOP3ClientEvent read FOnComplete write FOnComplete;
property OnSyncComplete: TPOP3ClientEvent read FOnSyncComplete write FOnSyncComplete;
end;
{ }
{ TfndPOP3Client }
{ }
type
TfndPOP3Client = class(TPOP3Client)
published
property Host;
property Port;
property LocalHost;
property LocalPort;
property Proxy;
property OnLog;
property LogTo;
property TimeOut;
property Active;
property ThrottleRead;
property ReadThrottleRate;
property Action;
property Username;
property Password;
property DisableAPOP;
property OnStatus;
property OnSyncStatus;
property OnLoggedIn;
property OnMailboxStats;
property OnComplete;
property OnSyncComplete;
property OnSocketStateChange;
property OnConnected;
property OnConnectFailed;
property OnClose;
property OnSyncSocketStateChange;
property OnSyncConnected;
property OnSyncConnectFailed;
property OnSyncClose;
end;
implementation
uses
{ Delphi }
Classes,
{ Fundamentals }
cStrings,
cReaders;
{ }
{ TPOP3Client }
{ }
procedure TPOP3Client.Init;
begin
inherited Init;
FPort := DefaultPOP3PortStr;
FStreamMode := smBlockWaitMessage;
FRunInThread := True;
FDisableAPOP := False;
end;
procedure TPOP3Client.SetAction(const Action: TPOP3ClientAction);
begin
if Action = FAction then
exit;
FAction := Action;
if [csDesigning, csLoading] * ComponentState <> [] then
exit;
if Action = pcaNone then
exit;
SetActive(True);
end;
procedure TPOP3Client.ThreadRun;
begin
Connect;
FServerReady := GetResponse(FWelcomeMsg);
FAPOPStamp := DecodeAPOPStamp(FWelcomeMsg);
if FAction in [pcaNone, pcaConnect] then
exit;
SetLoggedIn(True);
Case FAction of
pcaLogIn : ;
pcaMailboxStats : GetStats;
end;
TriggerComplete;
end;
procedure TPOP3Client.NotifyStatus;
begin
if Assigned(FOnSyncStatus) then
FOnSyncStatus(self, FStatusMsg);
end;
procedure TPOP3Client.NotifyComplete;
begin
if Assigned(FOnSyncComplete) then
FOnSyncComplete(self);
end;
procedure TPOP3Client.TriggerLoggedIn;
begin
if Assigned(FOnLoggedIn) then
FOnLoggedIn(self);
end;
procedure TPOP3Client.TriggerMailboxStats;
begin
if Assigned(FOnMailboxStats) then
FOnMailboxStats(self);
end;
procedure TPOP3Client.TriggerComplete;
begin
if Assigned(FOnComplete) then
FOnComplete(self);
if Assigned(FOnSyncComplete) then
Synchronize(NotifyComplete);
end;
{ Command / Response }
function TPOP3Client.Readln: String;
begin
Result := FStream.Reader.ExtractLine(MaxPop3LineLength, [eolEOF, eolCRLF]);
end;
function TPOP3Client.GetResponse(var Msg: String): Boolean;
var C : Char;
begin
if FTerminated then
raise EPOP3Client.Create('Session terminated');
C := Char(FStream.ReadByte);
if not (C in ['+', '-']) then
raise EPOP3Client.Create('Invalid response.' + Readln);
Result := C = '+';
if FTerminated then
raise EPOP3Client.Create('Session terminated');
Msg := Readln;
StatusMessage(Msg);
end;
function TPOP3Client.GetMultiLineLine: String;
begin
if FTerminated then
raise EPOP3Client.Create('Session terminated');
Result := Readln;
if (Length(Result) > 1) and (Result[1] = '.') then
Delete(Result, 1, 1);
end;
procedure TPOP3Client.StatusMessage(const Msg: String);
begin
FStatusMsg := Msg;
if Assigned(FOnStatus) then
begin
FOnStatus(self, Msg);
if FTerminated then
raise EPOP3Client.Create('Session terminated');
end;
if Assigned(FOnSyncStatus) then
Synchronize(NotifyStatus);
end;
procedure TPOP3Client.SendCommand(const S: String);
begin
if FTerminated then
raise EPOP3Client.Create('Session terminated');
FStream.WriteStr(S + CRLF);
end;
{ Authentication }
procedure TPOP3Client.Login(const UserName, Password: String);
var S : String;
begin
StatusMessage('Logging in ' + UserName);
SendCommand('USER ' + UserName);
if not GetResponse(S) then
raise EPOP3Client.Create('User not accepted: ' + S);
if Password <> '' then
begin
SendCommand('PASS ' + Password);
if not GetResponse(S) then
raise EPOP3Client.Create('Authentication failed: ' + S);
end;
end;
procedure TPOP3Client.APOPLogin(const UserName, Password: String);
var S : String;
begin
if FAPOPStamp = '' then
raise EPOP3Client.Create('Server does not support APOP');
StatusMessage('Logging in ' + UserName + ' with APOP');
SendCommand(EncodeAPOPCommand(FAPOPStamp, Username, Password));
if not GetResponse(S) then
raise EPOP3Client.Create('APOP Login failed: ' + S);
end;
procedure TPOP3Client.Logout;
var S : String;
begin
SendCommand('QUIT');
if not GetResponse(S) then
raise Epop3Client.Create('Error logging out:' + S);
end;
function TPOP3Client.GetAPOPSupported: Boolean;
begin
Active := True;
Result := FAPOPStamp <> '';
end;
procedure TPOP3Client.SetLoggedIn(const LoggedIn: Boolean);
var APOP : Boolean;
begin
if FLoggedIn = LoggedIn then
exit;
if LoggedIn then
begin
APOP := not FDisableAPOP and APOPSupported;
if APOP then
APOPLogin(FUserName, FPassword)
else
Login(FUserName, FPassword);
FLoggedIn := True;
TriggerLoggedIn;
end
else
begin
Logout;
FLoggedIn := False;
end;
end;
procedure TPOP3Client.SetUsername(const Username: String);
begin
if LoggedIn then
raise EPop3Client.Create('Can not change username while logged in.');
FUsername := Username;
end;
procedure TPOP3Client.SetPassword(const Password: String);
begin
if LoggedIn then
raise EPop3Client.Create('Can not change password while logged in.');
FPassword := Password;
end;
{ Server Greeting }
function TPOP3Client.GetWelcomeMsg: String;
begin
Active := True;
Result := FWelcomeMsg;
end;
function TPOP3Client.GetServerReady: Boolean;
begin
Active := True;
Result := FServerReady;
end;
{ Server Capabilities }
procedure TPOP3Client.GetCapabilities;
var S : String;
begin
if FSentCAPA then
exit;
SetActive(True);
SendCommand('CAPA');
FSentCAPA := True;
FCAPAFailed := not GetResponse(S);
if FCAPAFailed then
begin
FCapaUIDL := True;
FCapaTOP := True;
FCapaUSER := True;
exit;
end;
FCapaUIDL := False;
FCapaTOP := False;
FCapaUSER := False;
Repeat
S := UpperCase(StrBeforeChar(Trim(GetMultiLineLine), ' ', True));
if S = 'TOP' then
FCapaTOP := True else
if S = 'UIDL' then
FCapaUIDL := True else
if S = 'USER' then
FCapaUSER := True;
Until S = '.';
end;
function TPOP3Client.GetHaveServerCapabilities: Boolean;
begin
GetCapabilities;
Result := FSentCAPA and not FCAPAFailed;
end;
function TPOP3Client.GetCapaUIDL: Boolean;
begin
GetCapabilities;
Result := FCapaUIDL;
end;
function TPOP3Client.GetCapaTOP: Boolean;
begin
GetCapabilities;
Result := FCapaTOP;
end;
function TPOP3Client.GetCapaUSER: Boolean;
begin
GetCapabilities;
Result := FCapaUSER;
end;
{ }
procedure TPOP3Client.DeleteMessage(const MsgNr: Integer);
var S : String;
begin
SendCommand('DELE ' + IntToStr(MsgNr));
if not GetResponse(S) then
raise Epop3Client.Create('Error deleting message: ' + S);
FStatsUpToDate := False;
end;
function TPOP3Client.GetMessage(const MsgNr: Integer): String;
var S : String;
begin
S := IntToStr(MsgNr);
StatusMessage('Retrieving message ' + S + '.');
SendCommand('RETR ' + S);
if not GetResponse(S) then
raise EPOP3client.Create('Error retrieving message: ' + S);
Result := '';
Repeat
S := Readln;
if (S <> '') and (S[1] = '.') then
if S = '.' then
break
else
Delete(S, 1, 1);
Result := Result + S + CRLF;
Until False;
end;
procedure TPOP3Client.GetMessage(const MsgNr: Integer; var Hdr: String;
const MessageBody: AStream);
var S : String;
begin
S := IntToStr(MsgNr);
StatusMessage('Retrieving message ' + S + '.');
SendCommand('RETR ' + S);
if not GetResponse(S) then
raise EPOP3client.Create('Error retrieving message: ' + S);
Repeat
S := Readln;
if S = '' then
break;
Hdr := Hdr + S + CRLF;
Until False;
StreamDotLineTerminated(Stream, MessageBody, nil);
end;
{ Stats }
procedure TPOP3Client.GetStats;
var S : String;
T : StringArray;
begin
T := nil;
if FStatsUpToDate then
exit;
SetLoggedIn(True);
StatusMessage('Checking for new mail');
SendCommand('STAT');
if not GetResponse(S) then
raise EPOP3Client.Create('Error checking for new mail: ' + S);
T := StrSplitChar(S, ' ');
if Length(T) >= 3 then
begin
FMessageCount := StrToIntDef(T[1], -1);
FTotalSize := StrToInt64Def(T[2], -1);
FStatsUpToDate := True;
end
else
raise EPOP3Client.Create('The server returned an invalid response');
TriggerMailboxStats;
end;
function TPOP3Client.GetMessageCount: Integer;
begin
GetStats;
Result := FMessageCount;
end;
function TPOP3Client.GetTotalSize: Int64;
begin
GetStats;
Result := FTotalSize;
end;
{ Message sizes }
function TPOP3Client.GetMessageSizes(var MsgNrs: IntegerArray): Int64Array;
var S : String;
I : Integer;
L : Int64;
begin
StatusMessage('Checking new mail');
SendCommand('LIST');
if not GetResponse(S) then
raise EPOP3Client.Create('List of messages not available: ' + S);
MsgNrs := nil;
Result := nil;
Repeat
S := GetMultiLineLine;
if S <> '.' then
begin
I := StrToIntDef(StrBeforeChar(S, ' ', False), -1);
L := StrToInt64Def(StrAfterChar(S, ' '), -1);
if (L <> -1) and (I <> -1) then
begin
Append(MsgNrs, I);
Append(Result, L);
end;
end;
Until S = '.';
end;
function TPOP3Client.GetMessageUID(const MsgNr: Integer): String;
var S : String;
begin
SendCommand('UIDL ' + IntToStr(MsgNr));
if not GetResponse(S) then
raise EPOP3Client.Create('Message UID not available: ' + S);
Result := StrAfterChar(StrAfterChar(S, ' '), ' ');
end;
function TPOP3Client.GetMessageUIDs(var MsgNrs: IntegerArray): StringArray;
var S : String;
I : Integer;
begin
StatusMessage('Checking new mail');
SendCommand('UIDL');
if not GetResponse(S) then
raise EPOP3Client.Create('Unique IDs not available: ' + S);
MsgNrs := nil;
Result := nil;
Repeat
S := GetMultiLineLine;
if S <> '.' then
begin
I := StrToIntDef(StrBeforeChar(S, ' ', False), -1);
S := Trim(StrAfterChar(S, ' '));
if (I <> -1) and (S <> '') then
begin
Append(MsgNrs, I);
Append(Result, S);
end;
end;
Until S = '.';
end;
function TPOP3Client.GetMessageSize(const MsgNr: Integer): Int64;
var S : String;
begin
SendCommand('LIST ' + IntToStr(MsgNr));
if not GetResponse(S) then
raise EPOP3Client.Create('Message size not available: ' + S);
Result := StrToInt64Def(S, -1);
end;
function TPOP3Client.GetMessageHeader(const MsgNr: Integer; const PreviewLines: Integer; var Preview: String): THeader;
var S : String;
Head : Boolean;
begin
StatusMessage('Retrieving mail header for message ' + IntToStr(MsgNr));
SendCommand('TOP ' + IntToStr(MsgNr) + ' ' + IntToStr(PreviewLines));
if not GetResponse(S) then
raise EPOP3Client.Create('Error retrieving message header: ' + S);
Preview := '';
Head := True;
Result := THeader.Create;
try
Repeat
S := GetMultiLineLine;
if Head then
begin
if S = '' then
Head := False else
if (S <> '.') and not (S[1] in csWhiteSpace) then
try
Result.AddField(S);
except end;
end else
if S <> '.' then
begin
if (S <> '') and (S[1] = '.') then
Delete(S, 1, 1);
Preview := Preview + S + CRLF;
end;
Until FStream.EOF or (S = '.');
except
FreeAndNil(Result);
raise;
end;
end;
function TPOP3Client.GetMessageHeaders(const MsgNrs: IntegerArray; const PreviewLines: Integer; var Previews: StringArray): THeaderArray;
var I : Integer;
P : String;
begin
Result := nil;
Previews := nil;
StatusMessage('Retrieving mail headers');
try
For I := 0 to Length(MsgNrs) - 1 do
begin
Append(ObjectArray(Result), GetMessageHeader(MsgNrs[I], PreviewLines, P));
if PreviewLines > 0 then
Append(Previews, P);
end;
except
FreeObjectArray(Result);
raise;
end;
end;
end.