imapsend.pas

snmp设计增加相应SNMP的OID,是实时处理的.

{==============================================================================|
| Project : Ararat Synapse                                       | 002.005.000 |
|==============================================================================|
| Content: IMAP4rev1 client                                                    |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2004.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(IMAP4 rev1 protocol client)

Used RFC: RFC-2060, RFC-2595
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit imapsend;

interface

uses
  SysUtils, Classes,
  {$IFDEF STREAMSEC}
  TlsInternalServer, TlsSynaSock,
  {$ENDIF}
  blcksock, synautil;

const
  cIMAPProtocol = '143';

type
  {:@abstract(Implementation of IMAP4 protocol.)
   Note: Are you missing properties for setting Username and Password? Look to
   parent @link(TSynaClient) object!

   Are you missing properties for specify server address and port? Look to
   parent @link(TSynaClient) too!}
  TIMAPSend = class(TSynaClient)
  protected
    {$IFDEF STREAMSEC}
    FSock: TSsTCPBlockSocket;
    FTLSServer: TCustomTLSInternalServer;
    {$ELSE}
    FSock: TTCPBlockSocket;
    {$ENDIF}
    FTagCommand: integer;
    FResultString: string;
    FFullResult: TStringList;
    FIMAPcap: TStringList;
    FAuthDone: Boolean;
    FSelectedFolder: string;
    FSelectedCount: integer;
    FSelectedRecent: integer;
    FSelectedUIDvalidity: integer;
    FUID: Boolean;
    FAutoTLS: Boolean;
    FFullSSL: Boolean;
    function ReadResult: string;
    function AuthLogin: Boolean;
    function Connect: Boolean;
    procedure ParseMess(Value:TStrings);
    procedure ParseFolderList(Value:TStrings);
    procedure ParseSelect;
    procedure ParseSearch(Value:TStrings);
    procedure ProcessLiterals;
  public
    constructor Create;
    destructor Destroy; override;

    {:By this function you can call any IMAP command. Result of this command is
     in adequate properties.}
    function IMAPcommand(Value: string): string;

    {:By this function you can call any IMAP command what need upload any data.
     Result of this command is in adequate properties.}
    function IMAPuploadCommand(Value: string; const Data:TStrings): string;

    {:Call CAPABILITY command and fill IMAPcap property by new values.}
    function Capability: Boolean;

    {:Connect to IMAP server and do login to this server. This command begin
     session.}
    function Login: Boolean;

    {:Disconnect from IMAP server and terminate session session. If exists some
     deleted and non-purged messages, these messages are not deleted!}
    function Logout: Boolean;

    {:Do NOOP. It is for prevent disconnect by timeout.}
    function NoOp: Boolean;

    {:Lists folder names. You may specify level of listing. If you specify
     FromFolder as empty string, return is all folders in system.}
    function List(FromFolder: string; const FolderList: TStrings): Boolean;

    {:Lists folder names what match search criteria. You may specify level of
     listing. If you specify FromFolder as empty string, return is all folders
     in system.}
    function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;

    {:Lists subscribed folder names. You may specify level of listing. If you
     specify FromFolder as empty string, return is all subscribed folders in
     system.}
    function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;

    {:Lists subscribed folder names what matching search criteria. You may
     specify level of listing. If you specify FromFolder as empty string, return
     is all subscribed folders in system.}
    function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;

    {:Create a new folder.}
    function CreateFolder(FolderName: string): Boolean;

    {:Delete a folder.}
    function DeleteFolder(FolderName: string): Boolean;

    {:Rename folder names.}
    function RenameFolder(FolderName, NewFolderName: string): Boolean;

    {:Subscribe folder.}
    function SubscribeFolder(FolderName: string): Boolean;

    {:Unsubscribe folder.}
    function UnsubscribeFolder(FolderName: string): Boolean;

    {:Select folder.}
    function SelectFolder(FolderName: string): Boolean;

    {:Select folder, but only for reading. Any changes are not allowed!}
    function SelectROFolder(FolderName: string): Boolean;

    {:Close a folder. (end of Selected state)}
    function CloseFolder: Boolean;

    {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
     result is number of unseen messages in folder. For another status
     indentificator check IMAP documentation and documentation of your IMAP
     server (each IMAP server can have their own statuses.)}
    function StatusFolder(FolderName, Value: string): integer;

    {:Hardly delete all messages marked as 'deleted' in current selected folder.}
    function ExpungeFolder: Boolean;

    {:Touch to folder. (use as update status of folder, etc.)}
    function CheckFolder: Boolean;

    {:Append given message to specified folder.}
    function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;

    {:'Delete' message from currect selected folder. It mark message as Deleted.
     Real deleting waill be done after sucessfull @link(CloseFolder) or
     @link(ExpungeFolder)}
    function DeleteMess(MessID: integer): boolean;

    {:Get full message from specified message in selected folder.}
    function FetchMess(MessID: integer; const Mess: TStrings): Boolean;

    {:Get message headers only from specified message in selected folder.}
    function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;

    {:Return message size of specified message from current selected folder.}
    function MessageSize(MessID: integer): integer;

    {:Copy message from current selected folder to another folder.}
    function CopyMess(MessID: integer; ToFolder: string): Boolean;

    {:Return message numbers from currently selected folder as result
     of searching. Search criteria is very complex language (see to IMAP
     specification) similar to SQL (but not same syntax!).}
    function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;

    {:Sets flags of message from current selected folder.}
    function SetFlagsMess(MessID: integer; Flags: string): Boolean;

    {:Gets flags of message from current selected folder.}
    function GetFlagsMess(MessID: integer; var Flags: string): Boolean;

    {:Add flags to message's flags.}
    function AddFlagsMess(MessID: integer; Flags: string): Boolean;

    {:Remove flags from message's flags.}
    function DelFlagsMess(MessID: integer; Flags: string): Boolean;

    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
    function StartTLS: Boolean;

    {:return UID of requested message ID.}
    function GetUID(MessID: integer; var UID : Integer): Boolean;

    {:Try to find given capabily in capabilty string returned from IMAP server.}
    function FindCap(const Value: string): string;
  published
    {:Status line with result of last operation.}
    property ResultString: string read FResultString;

    {:Full result of last IMAP operation.}
    property FullResult: TStringList read FFullResult;

    {:List of server capabilites.}
    property IMAPcap: TStringList read FIMAPcap;

    {:Authorization is successful done.}
    property AuthDone: Boolean read FAuthDone;

    {:Turn on or off usage of UID (unicate identificator) of messages instead
     only sequence numbers.}
    property UID: Boolean read FUID Write FUID;

    {:Name of currently selected folder.}
    property SelectedFolder: string read FSelectedFolder;

    {:Count of messages in currently selected folder.}
    property SelectedCount: integer read FSelectedCount;

    {:Count of not-visited messages in currently selected folder.}
    property SelectedRecent: integer read FSelectedRecent;

    {:This number with name of folder is unique indentificator of folder.
     (If someone delete folder and next create new folder with exactly same name
     of folder, this number is must be different!)}
    property SelectedUIDvalidity: integer read FSelectedUIDvalidity;

    {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;

    {:SSL/TLS mode is used from first contact to server. Servers with full
     SSL/TLS mode usualy using non-standard TCP port!}
    property FullSSL: Boolean read FFullSSL Write FFullSSL;
{$IFDEF STREAMSEC}                            
    property Sock: TSsTCPBlockSocket read FSock;
    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
    property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
  end;

implementation

constructor TIMAPSend.Create;
begin
  inherited Create;
  FFullResult := TStringList.Create;
  FIMAPcap := TStringList.Create;
{$IFDEF STREAMSEC}           
  FTLSServer := GlobalTLSInternalServer;
  FSock := TSsTCPBlockSocket.Create;
  FSock.BlockingRead := True;
{$ELSE}
  FSock := TTCPBlockSocket.Create;
{$ENDIF}
  FSock.ConvertLineEnd := True;
  FSock.SizeRecvBuffer := 32768;
  FSock.SizeSendBuffer := 32768;
  FTimeout := 60000;
  FTargetPort := cIMAPProtocol;
  FTagCommand := 0;
  FSelectedFolder := '';
  FSelectedCount := 0;
  FSelectedRecent := 0;
  FSelectedUIDvalidity := 0;
  FUID := False;
  FAutoTLS := False;
  FFullSSL := False;
end;

destructor TIMAPSend.Destroy;
begin
  FSock.Free;
  FIMAPcap.Free;
  FFullResult.Free;
  inherited Destroy;
end;


function TIMAPSend.ReadResult: string;
var
  s: string;
  x, l: integer;
begin
  Result := '';
  FFullResult.Clear;
  FResultString := '';
  repeat
    s := FSock.RecvString(FTimeout);
    if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
    begin
      FResultString := s;
      break;
    end
    else
      FFullResult.Add(s);
    if (s <> '') and (s[Length(s)]='}') then
    begin
      s := Copy(s, 1, Length(s) - 1);
      x := RPos('{', s);
      s := Copy(s, x + 1, Length(s) - x);
      l := StrToIntDef(s, -1);
      if l <> -1 then
      begin
        s := FSock.RecvBufferStr(l, FTimeout);
        FFullResult.Add(s);
      end;
    end;
  until FSock.LastError <> 0;
  s := Trim(separateright(FResultString, ' '));
  Result:=uppercase(Trim(separateleft(s, ' ')));
end;

procedure TIMAPSend.ProcessLiterals;
var
  l: TStringList;
  n, x: integer;
  b: integer;
  s: string;
begin
  l := TStringList.Create;
  try
    l.Assign(FFullResult);
    FFullResult.Clear;
    b := 0;
    for n := 0 to l.Count - 1 do
    begin
      s := l[n];
      if b > 0 then
      begin
        FFullResult[FFullresult.Count - 1] :=
          FFullResult[FFullresult.Count - 1] + s;
        inc(b);
        if b > 2 then
          b := 0;
      end
      else
      begin
        if (s <> '') and (s[Length(s)]='}') then
        begin
          x := RPos('{', s);
          Delete(s, x, Length(s) - x + 1);
          b := 1;
        end
        else
          b := 0;
        FFullResult.Add(s);
      end;
    end;
  finally
    l.Free;
  end;
end;

function TIMAPSend.IMAPcommand(Value: string): string;
begin
  Inc(FTagCommand);
  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
  Result := ReadResult;
end;

function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
var
  l: integer;
begin
  Inc(FTagCommand);
  l := Length(Data.Text);
  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
  FSock.RecvString(FTimeout);
  FSock.SendString(Data.Text + CRLF);
  Result := ReadResult;
end;

procedure TIMAPSend.ParseMess(Value:TStrings);
var
  n: integer;
begin
  Value.Clear;
  for n := 0 to FFullResult.Count - 2 do
    if FFullResult[n][Length(FFullResult[n])] = '}' then
    begin
      Value.Text := FFullResult[n + 1];
      Break;
    end;
end;

procedure TIMAPSend.ParseFolderList(Value:TStrings);
var
  n, x: integer;
  s: string;
begin
  ProcessLiterals;
  Value.Clear;
  for n := 0 to FFullResult.Count - 1 do
  begin
    s := FFullResult[n];
    if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
    begin
      if s[Length(s)] = '"' then
      begin
        Delete(s, Length(s), 1);
        x := RPos('"', s);
      end
      else
        x := RPos(' ', s);
      if (x > 0) then
        Value.Add(Copy(s, x + 1, Length(s) - x));
    end;
  end;
end;

procedure TIMAPSend.ParseSelect;
var
  n: integer;
  s, t: string;
begin
  ProcessLiterals;