Email服务器

开发平台：
Delphi

uCheckEmailThread.pas：源码内容
							//
//检查新邮件
//
unit uCheckEmailThread;
interface
uses Classes,IniFiles,WinSock,Windows,SysUtils;
const
  RESPONSE_OK='+OK';
  RESPONSE_ERR='-ERR';
  DATA_END=#$D#$A'.'#$D#$A;
  CRLF=#$D#$A;
  
type
  TAccount=record
    Pop3ServerAddr:string[120];
    SeverPort:Integer;
    EmailAccount:string[120];
    EmailPwd:string[20];
  end;
  TAccounts=array of TAccount;
  TCheckEmailSocket=class
  private
    FSocketTalk:TSocket;
    FTimeOut:Integer; //以秒记
    FWaitServer:Boolean;
    FBuffer:TStringStream;
    procedure SetTimeOut(const Value: Integer);
  protected
    function SendCmd(CMD:string):Boolean;
    function RecvBuffer(EndStr:string=DATA_END):Boolean;
    procedure WaitServer;
  public
    function Login(UserName,Password:string):Boolean;
    function Connect(Server:string;Port:Word):Boolean;
    function Quit:Boolean;
    function GetUIDLS(List:TStrings):Boolean;
    constructor Create;
    destructor Destroy;override;
    property  TimeOut:Integer  read FTimeOut write SetTimeOut;
  end;
  TNewEmailArrive=procedure (Sender:TObject;NewEmailUIDLs:TStrings) of object;
  TCheckEmailThread=class(TThread)
  private
    FCheckEmailSocket:TCheckEmailSocket;
    FAccounts:TAccounts; //保存需要检查新邮件的邮箱的信息
    //FBlackList,
    //FWhiteList:TStrings;    //保存黑白名单
    FOldEmailUIDLS, //保存已经下载了的email的uidl
    FUILDsOnServer,
    FNewEmailUIDLs:TStrings;
    FNewEmailArrive:TNewEmailArrive;
    procedure DoOnNewEmail;
    procedure SetOldEmailUIDLS(const Value: TStrings);
  protected
    procedure Execute;override;
  public
    constructor Create(AAccount:TAccounts;AOldEmailUIDLS:TStrings);
    destructor Destroy;override;
    property  OnNewEmailArrive:TNewEmailArrive  read FNewEmailArrive write FNewEmailArrive;
    property  OldEmailUIDLS:TStrings  read FOldEmailUIDLS write SetOldEmailUIDLS;
  end;
implementation
uses uCommon;
{ TCheckEmailThread }
constructor TCheckEmailThread.Create(AAccount: TAccounts;
  AOldEmailUIDLS: TStrings);
var
  I:Integer;
begin
  inherited Create(True);
  SetLength(FAccounts,Length(AAccount));
  for I:=0 to Length(AAccount)-1 do FAccounts[I]:=AAccount[I];
  FOldEmailUIDLS:=THashedStringList.Create;
  FNewEmailUIDLs:=THashedStringList.Create;
  FUILDsOnServer:=THashedStringList.Create;
  FOldEmailUIDLS.Assign(AOldEmailUIDLS);
  Self.Priority:=tpLower;
  
  FreeOnTerminate:=True;
//  Resume;
end;
destructor TCheckEmailThread.Destroy;
begin
  FOldEmailUIDLS.Free;
  FNewEmailUIDLs.Free;
  FUILDsOnServer.Free;
  inherited;
end;
procedure TCheckEmailThread.DoOnNewEmail;
begin
  WriteLog('TCheckEmailThread.DoOnNewEmail_FNewEmailUIDLs.Text:'+FNewEmailUIDLs.Text);
  if Assigned(FNewEmailArrive) then FNewEmailArrive(Self,FNewEmailUIDLs);
end;
procedure TCheckEmailThread.Execute;
var
  I,J:Integer;
  info:PPop3LoginInfo;
begin
  WriteLog(#$D#$A'----------------CheckEmail Begin--------------------');
  for I:=0 to Length(FAccounts)-1 do
  begin
    if Self.Terminated then Exit;
    FUILDsOnServer.Clear;
    FCheckEmailSocket:=TCheckEmailSocket.Create;
    FCheckEmailSocket.TimeOut:=6;
    try
      if FCheckEmailSocket.Connect(FAccounts[I].Pop3ServerAddr,FAccounts[I].SeverPort) then
      begin
        try
          if Self.Terminated then Exit;
          if   FCheckEmailSocket.Login(FAccounts[I].EmailAccount,FAccounts[I].EmailPwd) then
          begin
            if Self.Terminated then Exit;
            if FCheckEmailSocket.GetUIDLS(FUILDsOnServer) then
            begin
              if Self.Terminated then Exit;
              FNewEmailUIDLs.Clear;
              for J:=0 to FUILDsOnServer.Count-1 do
              begin
                WriteLog('FUILDsOnServer:'+FUILDsOnServer.Text);
                WriteLog('FOldEmailUIDLS:'+FOldEmailUIDLS.Text);
                if FOldEmailUIDLS.IndexOf(PartStr(FUILDsOnServer[J],#32,True))=-1 then
                begin
                  New(info);
                  FillChar(info^,SizeOf(TPop3LoginInfo),0);
                  info.FPopServer:=FAccounts[I].Pop3ServerAddr;
                  info.FPort:=FAccounts[I].SeverPort;
                  info.FUserName:=FAccounts[I].EmailAccount;
                  info.FPwd:=FAccounts[I].EmailPwd;
                  FNewEmailUIDLs.AddObject(FUILDsOnServer[J],TObject(info));  //these Objects MUST dispose !!!
                end;
              end;
              if FNewEmailUIDLs.Count>0 then
                Synchronize(DoOnNewEmail);
              if Self.Terminated then Exit;
            end;
          end;
        finally
          FCheckEmailSocket.Quit;
        end;
      end;
    finally
      FCheckEmailSocket.Free;
    end;
  end;
  WriteLog('----------------CheckEmail END--------------------'#$D#$A);
end;
procedure TCheckEmailThread.SetOldEmailUIDLS(const Value: TStrings);
begin
  FOldEmailUIDLS.Assign(Value);
end;
{ TCheckEmailSocket }
function TCheckEmailSocket.Connect(Server: string; Port: Word): Boolean;
var
  Addr:sockaddr_in;
  PHost:PHostEnt;
  P:^LongInt;
begin
  PHost:=gethostbyname(PAnsiChar(Server));
  if PHost=nil then
    raise Exception.Create(SysErrorMessage(WSAGetLastError));
  Addr.sin_port:=htons(Port);
  Addr.sin_family:=AF_INET;
  P:=Pointer(PHost.h_addr_list^);
  Addr.sin_addr.S_addr:=P^;
  Result:= WinSock.connect(FSocketTalk,Addr, SizeOf(Addr))=0;
end;
constructor TCheckEmailSocket.Create;
var
  data:TWSAData;
  timeout:Integer;
  opt:LongBool;
begin
  if WSAStartup(MakeWord(2,0),data)<>0 then
    raise Exception.Create('Couldn''t find a usable  WinSock DLL');
  FBuffer:=TStringStream.Create('');
  FSocketTalk:=socket(AF_INET,SOCK_STREAM,0);
  if FSocketTalk=INVALID_SOCKET then raise Exception.Create('Couldn''t Allocate Socket Handle');
  FTimeOut:=6;
  opt:=True;
  setsockopt(FSocketTalk,SOL_SOCKET,SO_KEEPALIVE,@opt,SizeOf(LongBool));
  timeout:=2048;
  setsockopt(FSocketTalk,SOL_SOCKET,SO_RCVBUF,@timeout,SizeOf(timeout))
end;
destructor TCheckEmailSocket.Destroy;
begin
  FBuffer.Free;
  closesocket(FSocketTalk);
  WSACleanup;
  inherited;
end;
function TCheckEmailSocket.GetUIDLS(List: TStrings): Boolean;
begin
  List.Clear;
  Result:= SendCmd('UIDL '#$D#$A);
  if Result then
  begin
    Result:=RecvBuffer(DATA_END);
    if not Result then Exit;
    Result:=StrBeginWith(RESPONSE_OK,FBuffer.DataString);
    if Result then
    begin
      Split(#$D#$A,FBuffer.DataString,List);
      WriteLog('Split:'+List.Text);
      if List.Count>=2 then
      begin
        List.Delete(0);  //delte +OK
        List.Delete(List.Count-1); //delete .
      end;
      
      if List.Count>0 then
        if StrBeginWith(RESPONSE_OK+#32,List.Strings[0]) then List.Delete(0);
        
      Result:=List.Count>0;
      WriteLog('List.Text:'+List.Text);
    end;
  end;
end;
function TCheckEmailSocket.Login(UserName, Password: string): Boolean;
begin
   Result:= SendCmd('USER '+UserName+#$D#$A);
   if Result then
   begin
     Result:=RecvBuffer(#$D#$A);
     if not Result then Exit;
     Result:=StrBeginWith(RESPONSE_OK,FBuffer.DataString);
     if Result and SendCmd('PASS '+trim(password)+#$D#$A) then
     begin
       Result:=RecvBuffer(#$D#$A);
       if Result then Result := StrBeginWith(RESPONSE_OK,FBuffer.DataString);
     end;
  end;
end;
function TCheckEmailSocket.Quit: Boolean;
begin
  Result:= SendCmd('QUIT '#$D#$A);
  if Result then
    Result:=RecvBuffer(#$D#$A);
end;
function TCheckEmailSocket.RecvBuffer(EndStr:string): Boolean;
var
  ret:Integer;
  fdRead:TFDSet;
  t:timeval;
  TempBuf:PAnsiChar;
begin
  t.tv_sec:=FTimeOut;
  t.tv_usec:=0;
  Result:=False;
  FBuffer.Position:=0;
  FBuffer.Size:=0;
  GetMem(TempBuf,1024);
  try
    while True do
    begin
      FillChar(TempBuf^,1024,0);
      FD_ZERO(fdRead);
      FD_SET(FSocketTalk,fdRead);
      ret:= select(0,@fdRead,nil,nil,@t);
            
      IF FD_ISSET(FSocketTalk,fdRead) THEN
        FD_CLR(FSocketTalk,fdRead);
      if (ret=SOCKET_ERROR) or (ret=0) then  Break; {发生错误或超时}
      ret:=recv(FSocketTalk,TempBuf^,1024,0);
      if (ret=SOCKET_ERROR) OR (ret=0) then Break; {发生错误或服务器关闭连接}
      if ret >0 then
      begin
        FBuffer.WriteBuffer(TempBuf^,ret);
        if FBuffer.Size> Length(EndStr) then
        begin
          if StrEndWith(EndStr,FBuffer.DataString) then
          begin
            Result:=True;
            Break; //服务器发送完毕
          end;
        end;
      end;
    end;
  finally
    FreeMem(TempBuf);
  end;
end;
function TCheckEmailSocket.SendCmd(CMD: string): Boolean;
begin
  Result:= send(FSocketTalk,CMD[1],Length(CMD),0)<>SOCKET_ERROR;
  if Result and FWaitServer then WaitServer;
end;
procedure TCheckEmailSocket.SetTimeOut(const Value: Integer);
begin
  if FTimeOut<>Value then
  begin
    FTimeOut := Value;
    timeout:=FTimeOut*1000;
    setsockopt(FSocketTalk,IPPROTO_TCP,SO_SNDTIMEO,@timeout,SizeOf(Integer)); //if setsockopt's return<>0 then error;
  end;
end;
procedure TCheckEmailSocket.WaitServer;
begin
end;
end.

						