{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Implementation of the IMAP protocol RFC 3501.| }
{ |                https://tools.ietf.org/html/rfc3501          | }
{ |                                                             | }
{ |   Copyright (C) - 2018 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code distributed under MIT license.                | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }


{$INCLUDE GMCompilerSettings.inc}

unit GMImap;

interface

uses {$IFDEF JEDIAPI}{$IFNDEF FPC}jwaWinType,{$ENDIF}{$ELSE}Windows,{$ENDIF}
     GMStrDef, GMActiveX, GMCollections, GMIntf, GMCommon, GMINetBase, GMSockets;

type

  {ToDo: Handle EXPUNGE responses}
  {TODO: Improve ReconnectIfDisconnected}
  {TODO: ReadResponseLine exception when connection was closed by the server due to inactivity}
  {TODO: Restore IMAP state (Login and Mailbox) after reconnect}
  {TODO: Handle untagged Ok response PERMANENTFLAGS after EXAMINE/SELECT}
  {TODO: Better exception message if AllowedTags are violated}
  {TODO: Translate resource strings}


  //
  // Things universal to all e-mail clients
  //

  RCommandResponse = record
    CommandId: TGMString;
    ResponseMsg: TGMString;
  end;


  IGMClientAuthOperations = interface(IUnknown)
    ['{92C29799-D54E-45BD-80BD-DEAE2C9E22C2}']
    function ServerHasCapability(const ACapability: TGMString): Boolean;
    procedure ClearServerCapabilities;
    function StartCommand(const ACommand: TGMString): RCommandResponse;
    function ContinueCommand(const ACommandID: TGMString; ACommand: AnsiString): TGMString;
  end;


  IGMSASLClientAuthenticationHandler = interface(IGMGetName)
    ['{771610D6-0121-4B90-91C7-8B371E3480C2}']
    procedure ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString);
    function IsEnabled(const AClient: IGMClientAuthOperations): Boolean;
  end;


  TGMeMailClientBase = class(TGMINetProtocolBase, IGMClientAuthOperations)
   protected
    FHost, FPrevHost, FPort, FPrevPort, FUserName, FPassword: TGMString;
    FPrevUsingTLS: Boolean;
    FTransportLayerSocket: IGMSocketIO;
    FTransportLayer: ISequentialStream;
    FAskCanceled, FAskLoginData, FCertificateStatusNotifySink: IUnknown;
    FCertificateData: AnsiString;

   public // IGMClientAuthOperations
    function ServerHasCapability(const ACapability: TGMString): Boolean; virtual;
    procedure ClearServerCapabilities; virtual;
    function StartCommand(const ACommand: TGMString): RCommandResponse; virtual;
    function ContinueCommand(const ACommandID: TGMString; ACommand: AnsiString): TGMString; virtual;

   public
    function IsTransportLayerConnected: Boolean; virtual;
    function ConnectTransportLayer(AHost, APort: TGMString): IGMSocketIO; virtual;
    function IsUsingTLS: Boolean;
    procedure DisconnectTransportLayer; virtual;
    function ReconnectIfDisconnected: Boolean; virtual;
    function ChooseAuthenticationHandler(const AServerAuthSchemes: TGMStringArray): IGMSASLClientAuthenticationHandler;
    {$IFDEF TLS_SUPPORT}
    procedure ExecuteTLSNegotiation;
    {$ENDIF}
  end;


  //
  // IMAP client
  //

  EGMImapException = class(EGMINetException);

  TGMImapTagKind = (cmdTagged, cmdUntagged);
  TGMImapTagKinds = set of TGMImapTagKind;

  TGMImapResponseKind = (irkUnknown, irkOk, irkNo, irkBad, irkBye, irkPreAuth, irkCapability, irkList, irkLSub, irkStatus,
                         irkSearch, irkFlags, irkExists, irkRecent, irkExpunge, irkFetch);


  TGMImapMailBoxSystemFlag = (mbfSeen, mbfAnswered, mbfFlagged, mbfDeleted, mbfDraft, mbfRecent);
  TGMImapMailBoxSystemFlags = set of TGMImapMailBoxSystemFlag;


  TGMImapResponseDescRec = record
    ResponseKind: TGMImapResponseKind;
    AllowedTags: TGMImapTagKinds;
    SyntaxToken: TGMString;
  end;


  TGMImapMailboxCounterKind = (isvkMessages, isvkRecent, isvkUIDNext, isvkUIDValidity, isvkUnseen);
  TGMImapMailboxCounterKinds = set of TGMImapMailboxCounterKind;

  PGMImapMailboxCounters = ^TGMImapMailboxCounters;
  TGMImapMailboxCounters = record
    MailBoxName: TGMString;
    SystemFlags: TGMImapMailBoxSystemFlags;
    Counter: array [TGMImapMailboxCounterKind] of Int64;
  end;


  TGMImapMailboxAttribute = (maNoinferiors, maNoselect, maMarked, maUnmarked);
  TGMImapMailboxAttributes = set of TGMImapMailboxAttribute;

  IGMTellImapListEntry = interface(IUnknown)
    ['{0ECDB403-AE7F-47EC-B5F8-3C62181A60CE}']
    function TellImapListEntry(const AMailBoxName, APathDelimiter: TGMString; const AAttributes: TGMImapMailboxAttributes; const AEnumParam: PtrInt): Boolean;
  end;


  TGMImapResponseDescObj = class;

  IGMImapResponseDescObj = interface(IUnknown)
    ['{8CCE2D0A-49A2-4091-82B4-C935676B7392}']
    function Obj: TGMImapResponseDescObj;
  end;

  TGMImapResponseDescObj = class(TGMNameObj, IGMImapResponseDescObj)
   public
    FResponseKind: TGMImapResponseKind;
    FAllowedTags: TGMImapTagKinds;

    constructor Create(const AResponseKind: TGMImapResponseKind; const ASyntaxToken: TGMString; const AAllowedTags: TGMImapTagKinds); reintroduce; overload;
    function Obj: TGMImapResponseDescObj;
  end;


  PGMImapServerResponse = ^TGMImapServerResponse;
  TGMImapServerResponse = record
    CommandTagStr: TGMString;
    ResponseKind: TGMImapResponseKind;
    ResponseTagStr: TGMString;
    ResponseToken: TGMSTring;
    AllowedTags: TGMImapTagKinds;
    OptionalResposeCodeStr: TGMSTring;
    Number: Int64;
    MsgText: TGMString;
  end;


  TGMImapClient = class;
  TGMImapState = (istNotConnected, istUnAuthenticated, istAuthenticated, istSelected);


  PGMImapResponseDataDestinations = ^TGMImapResponseDataDestinations;
  TGMImapResponseDataDestinations = record
    EnumSink: IUnknown;
    EnumParam: PtrInt;
    EnumCanceled: Boolean;
    PStatusResponse: PGMImapMailboxCounters;
  end;


  IGMImapClient = interface(IUnknown)
    ['{D163A1B3-43C5-4BF7-8704-359A0B0519CD}']
    function Obj2: TGMImapClient;
  end;

  IGMImapCommand = Interface(IGMGetName)
    ['{CF34B0F9-ACD6-4539-B488-8B995FEEFE7D}']
    procedure ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse);
  end;

  TGMImapCommand = class(TGMNameAndStrValueObj, IGMImapCommand)
   public
    function QualifiedName: TGMString;
    function TagKinds: TGMImapTagKinds; virtual;
    procedure ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse); virtual;
  end;

  TGMImapCommandClass = class of TGMImapCommand;


  TGMSASLClientAuthenticationHandlerBase = class(TGMRefCountedObj, IGMGetName, IGMSASLClientAuthenticationHandler)
   protected
    FAuthSchemeName: TGMString;

   public
//  constructor Create(const AAuthSchemeName: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload;
    procedure ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString); virtual;
    function GetName: TGMString; stdcall;
    function IsEnabled(const AClient: IGMClientAuthOperations): Boolean; virtual;
  end;


  TGMSASLClientAuthenticationHandlerClass = class of TGMSASLClientAuthenticationHandlerBase;


  TGMPlainClientAuthenticationHandler = class(TGMSASLClientAuthenticationHandlerBase)
   public
    constructor Create(const ARefLifeTime: Boolean = True); override;
    procedure ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString); override;
  end;


  TGMLoginClientAuthenticationHandler = class(TGMSASLClientAuthenticationHandlerBase)
   public
    constructor Create(const ARefLifeTime: Boolean = True); override;
    procedure ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString); override;
    function IsEnabled(const AClient: IGMClientAuthOperations): Boolean; override;
  end;


  {$IFDEF TLS_SUPPORT}
  TGMNtlmClientAuthenticationHandler = class(TGMSASLClientAuthenticationHandlerBase)
   public
    constructor Create(const ARefLifeTime: Boolean = True); override;
    procedure ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString); override;
  end;
  {$ENDIF}


//TGMImapCommandLogout = class(TGMImapCommand)
// public
//  procedure ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse); override;
//end;

  {$IFDEF TLS_SUPPORT}
//TGMImapCommandStartTLS = class(TGMImapCommand)
// public
//  procedure ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse); override;
//end;
  {$ENDIF}


//IGMMailboxListEntry = interface(IGMGetName)
//  ['{53697C24-6782-44A2-A34A-E1B5943CB1F0}']
//  function GetPathDelimiter: TGMString;
//  function GetAttributes: TGMImapMailboxAttributes;
//
//  property PathDelimiter: TGMString read GetPathDelimiter;
//  property Attributes: TGMImapMailboxAttributes read GetAttributes;
//end;
//
//TGMMailboxListEntry = class(TGMNameObj, IGMMailboxListEntry)
// public
//  FPathDelimiter: TGMString;
//  FAttributes: TGMImapMailboxAttributes;
//
//  function GetPathDelimiter: TGMString;
//  function GetAttributes: TGMImapMailboxAttributes;
//
//  constructor Create(const AMailboxName, APathDelimiter: TGMString; const AAttributes: TGMImapMailboxAttributes; const ARefLifeTime: Boolean = True); overload;
//
////  property PathDelimiter: TGMString read GetPathDelimiter;
////  property Attributes: TGMImapMailboxAttributes read GetAttributes;
//end;


  TGMImapClient = class(TGMeMailClientBase, IGMImapClient)
   protected
    FNextCmdTagNo: PtrUInt;
    FCommandsInProgress: IGMIntfCollection;
    FState: TGMImapState;
    FServerCapabilities: IGMIntfCollection;
    FServerWantsDisconnect: Boolean;
    FSelectedMailbox: TGMImapMailboxCounters;
    FServerAuthSchemes: TGMStringArray;

    function BuildNextCmdTag: TGMString;
    function ExecCommand(const ACommand: TGMString; const AResponseDataDestinations: PGMImapResponseDataDestinations = nil; ACommandClass: TGMImapCommandClass = nil): TGMImapServerResponse;
    function UpdateCapabilities(const ACapabilities: TGMString): Boolean;

    procedure ProcessOkResponse(AServerResponse: PGMImapServerResponse);
    procedure ProcessUntaggedResponse(AServerResponse: PGMImapServerResponse; const AResponseDataDestinations: PGMImapResponseDataDestinations = nil);
    function ReadResponses(const ACommandTag: TGMString; const AResponseDataDestinations: PGMImapResponseDataDestinations = nil): TGMImapServerResponse;

   public
    constructor Create(const ARefLifeTime: Boolean = True); overload; override;
//  constructor Create(const ATransportLayer: ISequentialStream; const ARefLifeTime: Boolean = True); reintroduce; overload;
    destructor Destroy; override;

    function Obj2: TGMImapClient;
    function ProtocolDisplayName: TGMString; override;

    function ConnectTransportLayer(AHost, APort: TGMString): IGMSocketIO; override;
    procedure DisconnectTransportLayer; override;
    function ReconnectIfDisconnected: Boolean; override;

    procedure CheckServerHasCapability(const ACapability: TGMString; const ACallingName: TGMString = '');
    function CheckFindCommandInProgress(const ACommandTag: TGMString; const ARemove: Boolean): IGMImapCommand;

    // IGMClientAuthOperations
    function ServerHasCapability(const ACapability: TGMString): Boolean; override;
    function StartCommand(const ACommand: TGMString): RCommandResponse; override;
    function ContinueCommand(const ACommandID: TGMString; AClientData: AnsiString): TGMString; override;
    procedure ClearServerCapabilities; override;

    // Imap Commands
    procedure NOOP;
    procedure Authenticate(const AUserName, APassword: TGMString; const AAuthHandlerClass: TGMSASLClientAuthenticationHandlerClass = nil);
//  procedure Login(const AUserName, APassword: TGMString);
    procedure List(const AMailboxPath, AMailboxName: TGMString; const AEnumSink: IUnknown; const AEnumParam: PtrInt);
    function Status(const AMailboxName: TGMString; const AMailBoxCounterKinds: TGMImapMailboxCounterKinds): TGMImapMailboxCounters;
    procedure Close;
    procedure Expunge;
    procedure Logout;
    procedure Create_(const AMailboxName: TGMString);
    procedure Delete(const AMailboxName: TGMString);
    procedure Rename(const AExistingMailboxName, ANewMailboxName: TGMString);
    procedure Examine(const AMailboxName: TGMString);
    procedure Select(const AMailboxName: TGMString);
    procedure Fetch(const ADataItems: TGMString; const AEnumSink: IUnknown; const AEnumParam: PtrInt);
    function Capability: IGMIntfCollection;
    {$IFDEF TLS_SUPPORT}
    procedure StartTLS;
    {$ENDIF}

    property CommandsInProgress: IGMIntfCollection read FCommandsInProgress;
    property ServerCapabilities: IGMIntfCollection read FServerCapabilities;
    property State: TGMImapState read FState;
    property SelectedMailbox: TGMImapMailboxCounters read FSelectedMailbox;
  end;


  function ParseImapServerResponseLine(const AResponseLine: TGMString): TGMImapServerResponse;

  procedure ResetMailBoxCounters(var AMailboxCounters: TGMImapMailboxCounters);

  function GMAssignResponseDataDestinations(const AEnumSink: IUnknown = nil; const AEnumParam: PtrInt = 0; const APStatusResponse: PGMImapMailboxCounters = nil): TGMImapResponseDataDestinations;

  function ResponseMsgFromServerResponse(const AServerResponse: TGMImapServerResponse): TGMString;

  function InitCommandResponse(const ACommandId: TGMString = ''; const AResponseMsg: TGMString = ''): RCommandResponse;


const

  cGMImapSASL_IR = 'SASL-IR';

  cGMImapServerResponseDescs: array [TGMImapResponseKind] of TGMImapResponseDescRec =
  (
    (ResponseKind: irkUnknown; AllowedTags: []; SyntaxToken: ''),
    (ResponseKind: irkOk; AllowedTags: [cmdTagged, cmdUntagged]; SyntaxToken: 'OK'),
    (ResponseKind: irkNo; AllowedTags: [cmdTagged, cmdUntagged]; SyntaxToken: 'NO'),
    (ResponseKind: irkBad; AllowedTags: [cmdTagged, cmdUntagged]; SyntaxToken: 'BAD'),
    (ResponseKind: irkBye; AllowedTags: [cmdUntagged]; SyntaxToken: 'BYE'),
    (ResponseKind: irkPreAuth; AllowedTags: [cmdUntagged]; SyntaxToken: 'PREAUTH'),
    (ResponseKind: irkCapability; AllowedTags: [cmdUntagged]; SyntaxToken: 'CAPABILITY'),
    (ResponseKind: irkList; AllowedTags: [cmdUntagged]; SyntaxToken: 'LIST'),
    (ResponseKind: irkLSub; AllowedTags: [cmdUntagged]; SyntaxToken: 'LSUB'),
    (ResponseKind: irkStatus; AllowedTags: [cmdUntagged]; SyntaxToken: 'STATUS'),
    (ResponseKind: irkSearch; AllowedTags: [cmdUntagged]; SyntaxToken: 'SEARCH'),
    (ResponseKind: irkFlags; AllowedTags: [cmdUntagged]; SyntaxToken: 'FLAGS'),
    (ResponseKind: irkExists; AllowedTags: [cmdUntagged]; SyntaxToken: 'EXISTS'),
    (ResponseKind: irkRecent; AllowedTags: [cmdUntagged]; SyntaxToken: 'RECENT'),
    (ResponseKind: irkExpunge; AllowedTags: [cmdUntagged]; SyntaxToken: 'EXPUNGE'),
    (ResponseKind: irkFetch; AllowedTags: [cmdUntagged]; SyntaxToken: 'FETCH')
  );


  cAllStatusValueKinds = [Low(TGMImapMailboxCounterKind) .. High(TGMImapMailboxCounterKind)];

  cGMMailBoxCounterKindToken: array [TGMImapMailboxCounterKind] of TGMString = ('MESSAGES', 'RECENT', 'UIDNEXT', 'UIDVALIDITY', 'UNSEEN');

  cGMMailboxAttributeToken: array [TGMImapMailboxAttribute] of TGMString = ('\Noinferiors', '\Noselect', '\Marked', '\Unmarked');

  cGMImapMailBoxSystemFlagToken: array [TGMImapMailBoxSystemFlag] of TGMSTring = ('\Seen', '\Answered', '\Flagged', '\Deleted', '\Draft', '\Recent');

  cGMImapBase64Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,';

  cSASLAuthHandlerDefs: array [0..{$IFDEF TLS_SUPPORT}2{$ELSE}1{$ENDIF}] of TGMSASLClientAuthenticationHandlerClass =
     (TGMPlainClientAuthenticationHandler, TGMLoginClientAuthenticationHandler{$IFDEF TLS_SUPPORT}, TGMNtlmClientAuthenticationHandler{$ENDIF});
//cSASLAuthHandlerDefs: array [0..0] of TGMSASLClientAuthenticationHandlerClass = (TGMPlainClientAuthenticationHandler);


implementation

uses GMCharCoding {$IFDEF TLS_SUPPORT}, GMOpenSSL, GMNtlm{$ENDIF};

resourcestring

  RStrCmdTagNotFound = 'No command found with tag "%s"';
  RStrInvalidCmdTag = 'Invalid command tag "%s"';
  RStrFromServer = 'received from server';
  RStrBadCommand = '%s, bad command: %s';
  RStrCommandFailed = '%s, command failed: %s';
  RStrUnsupportedResponseToken = '%s, command response token not supported: "%s"';
  RStrCapabilityNotSupported = '%s Cpability "%s" not supported by the server';
//RStrLoginDisabled = 'The LOGIN command is disabled, call STARTTLS before using the LOGIN command';
//RStrLoginCommandNotSupported = 'The LOGIN command is not supported by the server, use AUTHENTICATE instead';
  RStrAuthschemeNotAllowed = 'The authentification scheme "%s" is disabled or not supported';
  RStrNoCommonAuthScheme = 'No authentication scheme found that is supported by both the client and the server';
  RStrCommandTagNotAllowed = '%s, command tag not allowed "%s"';
  RStrUnexpectedEndOfData = 'Unexpected end of Utf-7 data, expected: %s';
  RStrHyphenOrBase64Char = '"-" or BASE64 character';
  RStrUnterminatedBase64InUtf7 = 'Unterminated BASE64 sequence while decoding Utf-7';
  RStrImapNotConnected = 'Not connected to any IMAP server';
  RStrInvalidContinuationLineLength = 'Invalid continuation line length %d, should be %d';
  RStrMissingContinuationNumStart = 'Continuation line length start char "{" not found';


var

  vCSCreateServerResponseDescs: IGMCriticalSection = nil;
  vCSCreateSASLAuthHandlers: IGMCriticalSection = nil;

  vImapServerResponses: IGMIntfCollection = nil;
  vBase64ImapDecodeTable: RawByteString = '';
  vSASLAuthenticationHandlers: IGMIntfCollection = nil;


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

function SASLAuthenticationHandlers: IGMIntfCollection;
var i: Integer;
begin
  if vCSCreateSASLAuthHandlers <> nil then vCSCreateSASLAuthHandlers.EnterCriticalSection;
  try
   if vSASLAuthenticationHandlers = nil then
    begin
     vSASLAuthenticationHandlers := TGMIntfArrayCollection.Create(False, True, GMCompareByString);
     for i:=Low(cSASLAuthHandlerDefs) to High(cSASLAuthHandlerDefs) do
         vSASLAuthenticationHandlers.Add(cSASLAuthHandlerDefs[i].Create(True));
    end;

   Result := vSASLAuthenticationHandlers;
  finally
   if vCSCreateSASLAuthHandlers <> nil then vCSCreateSASLAuthHandlers.LeaveCriticalSection;
  end;
end;

procedure ClearImapServerResponse(var AServerResponse: TGMImapServerResponse);
begin
  AServerResponse.CommandTagStr := '';
  AServerResponse.ResponseKind := irkUnknown;
  AServerResponse.ResponseTagStr := '';
  AServerResponse.ResponseToken := '';
  AServerResponse.AllowedTags := [];
  AServerResponse.OptionalResposeCodeStr := '';
  AServerResponse.Number := 0;
  AServerResponse.MsgText := '';
end;

function InitCommandResponse(const ACommandId, AResponseMsg: TGMString): RCommandResponse;
begin
  Result.CommandId := ACommandId;
  Result.ResponseMsg := AResponseMsg;
end;


{ ---------------------------- }
{ ---- TGMeMailClientBase ---- }
{ ---------------------------- }

function TGMeMailClientBase.ConnectTransportLayer(AHost, APort: TGMString): IGMSocketIO;
var  socket: IGMSocket;
begin
  if not (GMSameText(FHost, AHost) and GMSameText(FPort, APort)) then
   begin
    DisconnectTransportLayer;
    socket := TGMTcpSocket.Create(vDfltInetAddrFamily, FAskCanceled);
    socket.Connect(AHost, APort);
    FTransportLayerSocket := socket;
    FTransportLayer := TGMSocketStream.Create(FTransportLayerSocket);
    FHost := AHost;
    FPort := APort;
   end;
  Result := socket;
end;

function TGMeMailClientBase.IsTransportLayerConnected: Boolean;
begin
  Result := FTransportLayer <> nil;
end;

procedure TGMeMailClientBase.DisconnectTransportLayer;
begin
  // May be entered more than once!
  FPrevUsingTLS := IsUsingTLS;
  FTransportLayer := nil;
  FTransportLayerSocket := nil;
  FPrevHost := FHost;
  FPrevPort := FPort;
  FHost := '';
  FPort := '';
end;

{$IFDEF TLS_SUPPORT}
procedure TGMeMailClientBase.ExecuteTLSNegotiation;
var socket: IGMSocket;
begin
  if GMQueryInterface(FTransportLayerSocket, IGMSocket, socket) then
   begin
    FTransportLayer := nil;
    FTransportLayerSocket := GMAddTlsLayer(socket, FHost, FCertificateStatusNotifySink, FCertificateData);
    FTransportLayer := TGMSocketStream.Create(FTransportLayerSocket);
   end;
end;
{$ENDIF}

function TGMeMailClientBase.IsUsingTLS: Boolean;
var objInfo: IGMObjInfo;
begin
  Result := GMQueryInterface(FTransportLayerSocket, IGMObjInfo, objInfo) and (objInfo.Instance is TGMOpenSslClientSocket);
end;

function TGMeMailClientBase.ReconnectIfDisconnected: Boolean;
begin
  Result := IsTransportLayerConnected;
  if not Result and (Length(FPrevHost) > 0) and (Length(FPrevPort) > 0) then
   begin
    ConnectTransportLayer(FPrevHost, FPrevPort);
    Result := IsTransportLayerConnected;
   end;
end;

function TGMeMailClientBase.ChooseAuthenticationHandler(const AServerAuthSchemes: TGMStringArray): IGMSASLClientAuthenticationHandler;
var i: Integer; unkName, unkAuthHandler: IUnknown;
begin
  for i:=Low(AServerAuthSchemes) to High(AServerAuthSchemes) do
   begin
    unkName := TGMNameObj.Create(AServerAuthSchemes[i], True);
    if SASLAuthenticationHandlers.Find(unkName, unkAuthHandler) and
       GMQueryInterface(unkAuthHandler, IGMSASLClientAuthenticationHandler, Result) and Result.IsEnabled(Self) then Exit;
   end;
  Result := nil;
end;

procedure TGMeMailClientBase.ClearServerCapabilities;
begin
  // Nothing, to be overridden in derived class.
end;

function TGMeMailClientBase.ContinueCommand(const ACommandID: TGMString; ACommand: AnsiString): TGMString;
begin
  Result := '';
  // Nothing, to be overridden in derived class.
end;

function TGMeMailClientBase.ServerHasCapability(const ACapability: TGMString): Boolean;
begin
  Result := False;
end;

function TGMeMailClientBase.StartCommand(const ACommand: TGMString): RCommandResponse;
begin
  // Nothing, to be overridden in derived class.
  Result := InitCommandResponse('', '');
end;


{ ------------------------------ }
{ ---- IMAP Global Routines ---- }
{ ------------------------------ }

function ImapServerResponseDescs: IGMIntfCollection;
var rk: TGMImapResponseKind;
begin
  if vCSCreateServerResponseDescs <> nil then vCSCreateServerResponseDescs.EnterCriticalSection;
  try
   if vImapServerResponses = nil then
    begin
     vImapServerResponses := TGMIntfArrayCollection.Create(False, True, GMCompareByString);
     for rk := Low(rk) to High(rk) do
         vImapServerResponses.Add(TGMImapResponseDescObj.Create(rk, cGMImapServerResponseDescs[rk].SyntaxToken, cGMImapServerResponseDescs[rk].AllowedTags));
    end;

   Result := vImapServerResponses;
  finally
   if vCSCreateServerResponseDescs <> nil then vCSCreateServerResponseDescs.LeaveCriticalSection;
  end;
end;

function InsertImapQuotedEscChars(const AValue: TGMString): TGMString;
var i: Integer;
begin
  Result := AValue;
  i:=1;
  while i <= Length(Result) do
   begin
    case Result[i] of
//   ' ': begin Result[i] := '\'; System.Insert('s', Result, i+1); Inc(i); end;
//   #9:  begin Result[i] := '\'; System.Insert('t', Result, i+1); Inc(i); end;
//   #10: begin Result[i] := '\'; System.Insert('n', Result, i+1); Inc(i); end;
//   #13: begin Result[i] := '\'; System.Insert('r', Result, i+1); Inc(i); end;
     '"': begin System.Insert('\', Result, i); Inc(i); end;
     '\': begin System.Insert('\', Result, i); Inc(i); end;
    end;
    Inc(i); // <- Additional increment here!
   end;
end;

function ResolveImapQuotedEscChars(const AValue: TGMString; const ACaller: TObject = nil): TGMString;
var i: Integer; ch, prevCh: TGMChar;
begin
  i:=1; Result := AValue; prevCh := #0;
  while i <= Length(Result) do
   begin
    ch := Result[i];
    if prevCh <> '\' then Inc(i) else
     case ch of
//    's': begin Result[i-1] := ' '; System.Delete(Result, i, 1); end; // <- No increment here!
//    't': begin Result[i-1] := #9; System.Delete(Result, i, 1); end; // <- No increment here!
//    'n': begin Result[i-1] := #10; System.Delete(Result, i, 1); end; // <- No increment here!
//    'r': begin Result[i-1] := #13; System.Delete(Result, i, 1); end; // <- No increment here!
      '"': begin System.Delete(Result, i-1, 1); ch := #0; end; // <- No increment here!
      '\': begin System.Delete(Result, i-1, 1); ch := #0; end; // <- No increment here!
      else raise EGMImapException.ObjError(GMFormat(RStrInvalidESCSequenceFmt, ['' + prevCh + ch, AValue, i-1]), ACaller, 'ResolveImapQuotedEscChars'); // Inc(i);
     end;
    prevCh := ch;
   end;
end;

function ImapMailboxNameNeedsQuotation(const AMailboxName: TGMString): Boolean;
var i: PtrInt;
begin
  for i:=1 to Length(AMailboxName) do
   case AMailboxName[i] of
    #0 .. #31, '(', ')', '{', ' ', '%', '*', '"', '\', ']': begin Result := True; Exit; end;
   end;
  Result := Length(AMailboxName) <= 0;
end;

function QuoteImapNameIfNeeded(const AMailboxName: TGMString): TGMString;
begin
  Result := AMailboxName;
  if ImapMailboxNameNeedsQuotation(Result) then Result := '"' + InsertImapQuotedEscChars(Result) + '"';
end;

function GMEncodeBase64ImapStr(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = False): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cGMImapBase64Alphabet, 6, AAddPadding, 4);
end;

function GMDecodeBase64ImapStr(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase64ImapDecodeTable, cGMImapBase64Alphabet);
  Result := GMDecodeBaseXX(AValue, vBase64ImapDecodeTable, 6, 'GMDecodeBase64ImapStr');
end;

procedure SwapByteOrder(var ABinValueString: AnsiString);
var i, j: PtrInt; ch: AnsiChar;
begin
//i:=1;
//while i <= Length(binStr) do
  for i:=0 to (Length(ABinValueString) div 2) - 1 do // <- a for loop does not have to check a condition, and should therefore be faster!
   begin
    j := i*2 + 1;
    ch := ABinValueString[j]; ABinValueString[j] := ABinValueString[j+1]; ABinValueString[j+1] := ch;
    // Inc(i, 2);
   end;
end;

function EncodeImapUtf7(const AValue: TGMString): TGMString;
var chPos: PtrInt; non7BitPart: UnicodeString;
  procedure TerminateBase64;
  var binStr: AnsiString;
  begin
    if Length(non7BitPart) > 0 then
     begin
      SetLength(binStr, Length(non7BitPart) * SizeOf(WideChar));
      System.Move(non7BitPart[1], binStr[1], Length(binStr));
      SwapByteOrder(binStr);
      Result := Result + '&' + GMEncodeBase64ImapStr(binStr, False) + '-';
      non7BitPart := '';
     end;
  end;
begin
  Result := ''; non7BitPart := '';
  for chPos:=1 to Length(AValue) do
   case AValue[chPos] of
    #$20 .. #$25, #$27 .. #$7e: begin TerminateBase64; Result := Result + AValue[chPos]; end;
    '&': Result := Result + '&-';
    else non7BitPart := non7BitPart + AValue[chPos];
   end;
  TerminateBase64;
end;

function DecodeImapUtf7(const AValue: TGMString; const ACaller: TObject = nil): TGMString;
var chPos: PtrInt; base64Part: TGMString; binStr: AnsiString; decodedStr: UnicodeString;
begin
  Result := ''; // base64Part := '';
  chPos := 1;
  while chPos <= Length(AValue) do
   begin
    case AValue[chPos] of
     #$20 .. #$25, #$27 .. #$7e: Result := Result + AValue[chPos];
     '&': begin
           if Length(AValue) <= chPos then raise EGMImapException.ObjError(GMFormat(RStrUnexpectedEndOfData, [RStrHyphenOrBase64Char]), ACaller, {$I %CurrentRoutine%});
           Inc(chPos);
           case AValue[chPos] of
            '-': Result := Result + '&';
            else
             begin
              base64Part := '';
              while (AValue[chPos] <> '-') and (chPos <= Length(AValue)) do
                   begin base64Part := base64Part + AValue[chPos]; Inc(chPos); end;
              if AValue[chPos] <> '-' then raise EGMImapException.ObjError(RStrUnterminatedBase64InUtf7, ACaller, {$I %CurrentRoutine%});
              binStr := GMDecodeBase64ImapStr(base64Part);
              base64Part := ''; // <- free memory early
              SwapByteOrder(binStr);
              SetLength(decodedStr, Length(binStr) div SizeOf(WideChar));
              System.Move(binStr[1], decodedStr[1], Length(decodedStr) * SizeOf(WideChar));
              Result := Result + decodedStr;
             end;
           end;
          end;
    end;
    Inc(chPos);
   end;
end;

function EncodeMailboxName(const AName: TGMString): TGMString;
begin
  Result := QuoteImapNameIfNeeded(EncodeImapUtf7(AName));
end;

function UnquotedName(const AName: TGMString): TGMString;
begin
  if (Length(AName) < 2) or (AName[1] <> '"') or (AName[Length(AName)] <> '"') then Result := AName else
     Result := ResolveImapQuotedEscChars(GMRemoveQuotes(AName));
end;

function NextQuotedWord(var AChPos: PtrInt; const AValue: TGMString; const ASepChar: TGMChar): TGMString;
var startPos: PtrInt; inDblQuotes: Boolean; // inSquareBrackets, inSingleQuotes
begin
  while (AChPos <= Length(AValue)) and (AValue[AChPos] = ASepChar) do Inc(AChPos);

  startPos := AChPos; inDblQuotes := False;
  while AChPos <= Length(AValue) do
   begin
    case AValue[AChPos] of
//   '[': inSquareBrackets := True;
//   ']': inSquareBrackets := False;
     '"': inDblQuotes := not inDblQuotes;
//   '''': inSingleQuotes := not inSingleQuotes;
     else if not inDblQuotes and (AValue[AChPos] = ASepChar) then Break;
    end;
    Inc(AChPos);
   end;

  if AChPos > startPos then Result := System.Copy(AValue, startPos, AChPos-startPos) else Result := '';
end;

procedure ResetMailBoxCounters(var AMailboxCounters: TGMImapMailboxCounters);
begin
  AMailboxCounters.MailBoxName := '';
  FillByte(AMailboxCounters.Counter, SizeOf(AMailboxCounters.Counter), 0);
  AMailboxCounters.SystemFlags := [];
end;

function GMAssignResponseDataDestinations(const AEnumSink: IUnknown; const AEnumParam: PtrInt; const APStatusResponse: PGMImapMailboxCounters): TGMImapResponseDataDestinations;
begin
  Result.EnumSink := AEnumSink;
  Result.EnumParam := AEnumParam;
  Result.PStatusResponse := APStatusResponse;
  Result.EnumCanceled := False;
end;


{ --------------------------------------- }
{ ---- Parsing Imap Server Responses ---- }
{ --------------------------------------- }

function ParseImapServerResponseLine(const AResponseLine: TGMString): TGMImapServerResponse;
var chPos, oldChPos: PtrInt; token: TGMString; searchName, foundDesc: IUnknown; responseDesc: IGMImapResponseDescObj;
begin
  ClearImapServerResponse(Result);

  chPos := 1;
  Result.ResponseTagStr := GMNextWord(chPos, AResponseLine, ' ');
  Result.ResponseToken := GMNextWord(chPos, AResponseLine, ' ');

  Result.Number := 0;
  if GMIsNumber(Result.ResponseToken) then
   begin
    Result.Number := GMStrToInt64(Result.ResponseToken);
    Result.ResponseToken := GMNextWord(chPos, AResponseLine, ' ');
   end;

  oldChPos := chPos;
  token := GMNextWord(chPos, AResponseLine, ' ');
  if (Length(token) <= 0) or (token[1] <> '[') then
    begin chPos := oldChPos; Result.OptionalResposeCodeStr := ''; end
  else
   begin
    if token[Length(token)] <> ']' then
     begin
      token := GMStringJoin(token, ' ', GMNextWord(chPos, AResponseLine, ']') + ']');
      if chPos <= Length(AResponseLine) then Inc(chPos);
     end;

    Result.OptionalResposeCodeStr := GMRemoveQuotes(token, '[', ']');
   end;

  Result.MsgText := System.Copy(AResponseLine, chPos, Length(AResponseLine) - chPos + 1);

  searchName := TGMNameObj.Create(Result.ResponseToken);
  if not ImapServerResponseDescs.Find(searchName, foundDesc) then
    begin Result.ResponseKind := irkUnknown; Result.AllowedTags := []; end
  else
   begin
    GMCheckQueryInterface(foundDesc, IGMImapResponseDescObj, responseDesc);
    Result.ResponseKind := responseDesc.Obj.FResponseKind;
    Result.AllowedTags := responseDesc.Obj.FAllowedTags;
   end;
end;

function ResponseMsgFromServerResponse(const AServerResponse: TGMImapServerResponse): TGMString;
begin
  Result := GMStringJoin(AServerResponse.ResponseToken, ' ', AServerResponse.MsgText);
//if Length(AServerResponse.MsgText) > 0 then
//  Result := AServerResponse.MsgText
//else
//  Result := AServerResponse.ResponseToken;
end;

procedure ParseStatusCounters(const AValue: TGMString; const AMailboxCounters: PGMImapMailboxCounters);
var chPos: PtrInt; nameToken, numToken: TGMString; imck: TGMImapMailboxCounterKind;
begin
  if AMailboxCounters = nil then Exit;

  chPos := 1;
  repeat
   nameToken := GMNextWord(chPos, AValue, ' ');
// if (Length(nameToken) > 0) and (nameToken[1] = '(') then System.Delete(nameToken, 1, 1);

   if Length(nameToken) > 0 then
    begin
     for imck := Low(imck) to High(imck) do
      if GMSameText(nameToken, cGMMailBoxCounterKindToken[imck]) then
        begin
         numToken := GMNextWord(chPos, AValue, ' ');
//       if (Length(numToken) > 0) and (numToken[Length(numToken)] = ')') then System.Delete(numToken, Length(numToken), 1);
         if GMIsNumber(numToken) then AMailboxCounters.Counter[imck] := GMStrToInt64(numToken);
         Break;
        end;
    end;
  until chPos > Length(AValue);
end;

procedure ParseImapStatusResponse(const AResponseLine: TGMString; const AMailboxCounters: PGMImapMailboxCounters);
var chPos: PtrInt; pStart, pEnd: PGMChar;
begin
  if AMailboxCounters = nil then Exit;

  chPos := 1;
  AMailboxCounters.MailBoxName := DecodeImapUtf7(UnquotedName(NextQuotedWord(chPos, AResponseLine, ' ')));

  if chPos > Length(AResponseLine) then Exit;

  pStart := GMStrLScan(@AResponseLine[chPos], '(', Length(AResponseLine) - chPos + 1);

  if pStart <> nil then
   begin
    Inc(pStart);
    pEnd := GMStrLScan(pStart, ')', PGMChar(AResponseLine) + Length(AResponseLine) - pStart);
    if pEnd = nil then pEnd := PGMChar(AResponseLine) + Length(AResponseLine);
    ParseStatusCounters(Copy(AResponseLine, pStart - PGMChar(AResponseLine) + 1, pEnd - pStart), AMailboxCounters);
   end;
end;

function ParseImapListResonse(const AResponseLine: TGMString; const AEnumSink: IUnknown; const AEnumParam: PtrInt): Boolean;
var chPos, chPos2: PtrInt; attributes, pathDelim, name, token: TGMString; a: TGMImapMailboxAttribute; attr: TGMImapMailboxAttributes;
    tellEntry: IGMTellImapListEntry;
begin
  if not GMQueryInterface(AEnumSink, IGMTellImapListEntry, tellEntry) then begin Result := False; Exit; end;

//if AResultCollection = nil then Exit;

  chPos := 1;
  while (chPos <= Length(AResponseLine)) and (AResponseLine[chPos] <> '(') do Inc(chPos);
  attributes := GMRemoveQuotes(GMNextWord(chPos, AResponseLine, ')'), '(', ')');
  Inc(chPos);

  attr := []; chPos2 := 1;
  if Length(attributes) > 0 then
   repeat
    token := GMNextWord(chPos2, attributes, ' ');
    if Length(token) > 0 then
      for a:=Low(a) to High(a) do
        if GMSameText(token, cGMMailboxAttributeToken[a]) then begin Include(attr, a); Break; end;
   until chPos2 > Length(attributes);

  pathDelim := UnquotedName(NextQuotedWord(chPos, AResponseLine, ' '));

  name := DecodeImapUtf7(UnquotedName(NextQuotedWord(chPos, AResponseLine, ' ')));

  Result := tellEntry.TellImapListEntry(name, pathDelim, attr, AEnumParam);
//AResultCollection.Add(TGMMailboxListEntry.Create(name, pathDelim, attr, True));
end;

function ParseUntaggedFetchResponse(const AResponseLine: TGMString; const AEnumSink: IUnknown; const AEnumParam: PtrInt): Boolean;
begin
  Result := True;
end;

function ParseImapFlagsResonse(const AResponseLine: TGMString): TGMImapMailBoxSystemFlags;
var chPos: PtrInt; token: TGMString; f: TGMImapMailBoxSystemFlag;
begin
  Result := []; chPos := 1;
  repeat
   token := GMRemoveQuotes(GMNextWord(chPos, AResponseLine, ' '), '(', ')');
   if Length(token) > 0 then
     for f:=Low(f) to High(f) do
       if GMSameText(token, cGMImapMailBoxSystemFlagToken[f]) then begin Include(Result, f); Break; end;
  until chPos > Length(AResponseLine);
end;


{ -------------------------------- }
{ ---- TGMImapResponseDescObj ---- }
{ -------------------------------- }

constructor TGMImapResponseDescObj.Create(const AResponseKind: TGMImapResponseKind; const ASyntaxToken: TGMString; const AAllowedTags: TGMImapTagKinds);
begin
  inherited Create(ASyntaxToken);
  FResponseKind := AResponseKind;
  FAllowedTags := AAllowedTags;
end;

function TGMImapResponseDescObj.Obj: TGMImapResponseDescObj;
begin
  Result := Self;
end;


{ ------------------------------------------------ }
{ ---- TGMSASLClientAuthenticationHandlerBase ---- }
{ ------------------------------------------------ }

//constructor TGMSASLClientAuthenticationHandlerBase.Create(const AAuthSchemeName: TGMString; const ARefLifeTime: Boolean);
//begin
//Create(ARefLifeTime);
//FAuthSchemeName := AAuthSchemeName;
//end;

function TGMSASLClientAuthenticationHandlerBase.GetName: TGMString;
begin
  Result := FAuthSchemeName;
end;

function TGMSASLClientAuthenticationHandlerBase.IsEnabled(const AClient: IGMClientAuthOperations): Boolean;
begin
  Result := True;
end;

procedure TGMSASLClientAuthenticationHandlerBase.ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString);
begin
  // Nothing, to be overridden in derived class.
end;


{ --------------------------------------------- }
{ ---- TGMPlainClientAuthenticationHandler ---- }
{ --------------------------------------------- }

constructor TGMPlainClientAuthenticationHandler.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FAuthSchemeName := 'PLAIN';
end;

procedure TGMPlainClientAuthenticationHandler.ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString);
var saslIR: Boolean; cmd, credentials: TGMString; cmdResponse: RCommandResponse;
begin
  if AClient = nil then raise EGMImapException.ObjError(MsgPointerIsNil('AClient argument'), Self, 'ExecuteAuthentification');

  saslIR := AClient.ServerHasCapability(cGMImapSASL_IR);
//saslIR := False; // <- For Testing

  AClient.ClearServerCapabilities;

  cmd := 'AUTHENTICATE PLAIN';
  credentials := GMEncodeBase64Str(#0 + GMStringToUtf8(AUserName) + #0 + GMStringToUtf8(APassword));

  if saslIR then cmd := cmd + ' ' + credentials;
  cmdResponse := AClient.StartCommand(cmd);
  if not saslIR then cmdResponse.ResponseMsg := AClient.ContinueCommand(cmdResponse.CommandId, credentials);
end;


{ --------------------------------------------- }
{ ---- TGMLoginClientAuthenticationHandler ---- }
{ --------------------------------------------- }

constructor TGMLoginClientAuthenticationHandler.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FAuthSchemeName := 'LOGIN';
end;

procedure TGMLoginClientAuthenticationHandler.ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString);
begin
  if AClient = nil then raise EGMImapException.ObjError(MsgPointerIsNil('AClient argument'), Self, 'ExecuteAuthentification');

  AClient.ClearServerCapabilities;
  AClient.StartCommand('LOGIN ' + QuoteImapNameIfNeeded(AUserName) + ' ' + QuoteImapNameIfNeeded(APassword));
end;

function TGMLoginClientAuthenticationHandler.IsEnabled(const AClient: IGMClientAuthOperations): Boolean;
begin
  if AClient = nil then Result := True else Result := not AClient.ServerHasCapability('LOGINDISABLED');
//Result := False; // <- test
end;


{ -------------------------------------------- }
{ ---- TGMNtlmClientAuthenticationHandler ---- }
{ -------------------------------------------- }

{$IFDEF TLS_SUPPORT}
constructor TGMNtlmClientAuthenticationHandler.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FAuthSchemeName := 'NTLM';
end;

procedure TGMNtlmClientAuthenticationHandler.ExecuteAuthentification(const AClient: IGMClientAuthOperations; const AUsername, APassword: TGMString);
var saslIR: Boolean; cmd: TGMString; cmdResponse: RCommandResponse; ntlmSvrResponse: TNTLMServerResponse;
begin
  if AClient = nil then raise EGMImapException.ObjError(MsgPointerIsNil('AClient argument'), Self, 'ExecuteAuthentification');

  saslIR := AClient.ServerHasCapability(cGMImapSASL_IR);
//saslIR := False; // <- For Testing

  AClient.ClearServerCapabilities;

  cmd := 'AUTHENTICATE NTLM';
//clientMsg := GMEncodeBase64Str(#0 + GMStringToUtf8(AUserName) + #0 + GMStringToUtf8(APassword));

  if saslIR then cmd := cmd + ' ' + BuildNTLMClientStartMsg;
  cmdResponse := AClient.StartCommand(cmd);
  if not saslIR then cmdResponse.ResponseMsg := AClient.ContinueCommand(cmdResponse.CommandId, BuildNTLMClientStartMsg);

  ntlmSvrResponse := DecodeNTLMServerChallengeMsg(cmdResponse.ResponseMsg);

  cmdResponse.ResponseMsg := AClient.ContinueCommand(cmdResponse.CommandId, BuildNTLMClientCredentialsMsg(AUsername, APassword, @ntlmSvrResponse));
end;
{$ENDIF}


{ ------------------------ }
{ ---- TGMImapCommand ---- }
{ ------------------------ }

function TGMImapCommand.QualifiedName: TGMString;
begin
  Result := GMStringJoin(ClassName, '.', StrValue);
end;

function TGMImapCommand.TagKinds: TGMImapTagKinds;
begin
  Result := [cmdTagged];
end;

procedure TGMImapCommand.ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse);
begin
  case AServerResponse.ResponseKind of
   irkOk:      if AImapClient <> nil then AImapClient.Obj2.ProcessOkResponse(@AServerResponse);
   irkNo:      raise EGMImapException.ObjError(GMFormat(RStrCommandFailed, [QualifiedName, AServerResponse.MsgText]), Self, {$I %CurrentRoutine%});
   irkBad:     raise EGMImapException.ObjError(GMFormat(RStrBadCommand, [QualifiedName, AServerResponse.MsgText]), Self, {$I %CurrentRoutine%});
// irkBye:     if AImapClient <> nil then AImapClient.Obj2.FState := istNotConnected; // <- should not occur, BYE is always untagged!
// irkPreAuth: if AImapClient <> nil then AImapClient.Obj2.FState := istAuthenticated; // <- should not occur, PREAUTH is always untagged!
   else raise EGMImapException.ObjError(GMFormat(RStrUnsupportedResponseToken, [QualifiedName, GMStringJoin(AServerResponse.ResponseToken, ', ', AServerResponse.MsgText)]), Self, {$I %CurrentRoutine%});
  end;

  if TagKinds * AServerResponse.AllowedTags = [] then
     raise EGMImapException.ObjError(GMFormat(RstrCommandTagNotAllowed, [QualifiedName, AServerResponse.ResponseTagStr]), Self, {$I %CurrentRoutine%});
end;


{ ------------------------------ }
{ ---- TGMImapCommandLogout ---- }
{ ------------------------------ }

//procedure TGMImapCommandLogout.ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse);
//begin
//inherited;
//if AImapClient <> nil then AImapClient.Obj2.DisconnectTransportLayer;
//end;


{ -------------------------------- }
{ ---- TGMImapCommandStartTLS ---- }
{ -------------------------------- }

{$IFDEF TLS_SUPPORT}
//procedure TGMImapCommandStartTLS.ProcessCmdResponse(const AImapClient: IGMImapClient; var AServerResponse: TGMImapServerResponse);
//begin
//inherited;
//if AImapClient <> nil then AImapClient.Obj2.ExecuteTLSNegotiation;
//end;
{$ENDIF}


{ ----------------------------- }
{ ---- TGMMailboxListEntry ---- }
{ ----------------------------- }

//constructor TGMMailboxListEntry.Create(const AMailboxName, APathDelimiter: TGMString; const AAttributes: TGMImapMailboxAttributes; const ARefLifeTime: Boolean);
//begin
//Create(AMailboxName, ARefLifeTime);
//FPathDelimiter := APathDelimiter;
//FAttributes := AAttributes;
//end;
//
//function TGMMailboxListEntry.GetPathDelimiter: TGMString;
//begin
//Result := FPathDelimiter;
//end;
//
//function TGMMailboxListEntry.GetAttributes: TGMImapMailboxAttributes;
//begin
//Result := FAttributes;
//end;


{ ----------------------- }
{ ---- TGMImapClient ---- }
{ ----------------------- }

constructor TGMImapClient.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FCommandsInProgress := TGMIntfArrayCollection.Create(False, True, GMCompareByString, True);
  FServerCapabilities := TGMIntfArrayCollection.Create(False, True, GMCompareByName, True);
end;

//constructor TGMImapClient.Create(const ATransportLayer: ISequentialStream; const ARefLifeTime: Boolean);
//begin
//Create(ARefLifeTime);
//FTransportLayer := ATransportLayer;
////if FTransportLayer <> nil then ReadResponses; // <- read initial server greeting message
//end;

destructor TGMImapClient.Destroy;
begin
  try Logout; except end; // <- never raise in destructors!
  inherited;
end;

function TGMImapClient.Obj2: TGMImapClient;
begin
  Result := Self;
end;

function TGMImapClient.ProtocolDisplayName: TGMString;
begin
  if IsUsingTLS then Result := 'IMAPS' else Result := 'IMAP';
end;

function TGMImapClient.ConnectTransportLayer(AHost, APort: TGMString): IGMSocketIO;
var implicitTLS: Boolean;
begin
  if Length(APort) <= 0 then APort := '143';
  implicitTLS := APort = '993';
  Result := inherited ConnectTransportLayer(AHost, APort);
  FState := istUnAuthenticated;
  {$IFDEF TLS_SUPPORT}
  if implicitTLS then ExecuteTLSNegotiation;
  {$ENDIF}
  ReadResponses('');
  if ServerCapabilities.IsEmpty then Capability; // <- if not already sent via server untagged OK greeting message
end;

procedure TGMImapClient.DisconnectTransportLayer;
begin
  // May be entered more than once!
  inherited;
  FServerWantsDisconnect := False;
  FState := istNotConnected;
  ClearServerCapabilities;
end;

function TGMImapClient.ReconnectIfDisconnected: Boolean;
var wasDisconnected: Boolean;
begin
  wasDisconnected := not IsTransportLayerConnected;
  Result := inherited ReconnectIfDisconnected;
  if wasDisconnected and Result and FPrevUsingTLS and not IsUsingTLS then StartTLS;
end;

function TGMImapClient.BuildNextCmdTag: TGMString;
const cZeros = '00000000000000000000';
begin
  Inc(FNextCmdTagNo);
  if FNextCmdTagNo > 9999999 then FNextCmdTagNo := 1;
  Result := GMIntToStr(FNextCmdTagNo);
  if Length(Result) < 7 then Result := System.Copy(cZeros, 1, 7 - Length(Result)) + Result;
end;

function TGMImapClient.CheckFindCommandInProgress(const ACommandTag: TGMString; const ARemove: Boolean): IGMImapCommand;
var searchName, unkFoundCmd: IUnknown;
begin
  searchName := TGMNameObj.Create(ACommandTag);
  if not CommandsInProgress.Find(searchName, unkFoundCmd) then raise EGMImapException.ObjError(GMFormat(RStrCmdTagNotFound, [ACommandTag]), Self, {$I %CurrentRoutine%});
  if ARemove then CommandsInProgress.RemoveByKey(unkFoundCmd);
  GMCheckQueryInterface(unkFoundCmd, IGMImapCommand, Result);
end;

function TGMImapClient.ServerHasCapability(const ACapability: TGMString): Boolean;
var key: IUnknown;
begin
  key := TGMNameObj.Create(ACapability);
  Result := GMCollectionContains(ServerCapabilities, key);
end;

procedure TGMImapClient.CheckServerHasCapability(const ACapability: TGMString; const ACallingName: TGMString);
begin
  if not ServerHasCapability(ACapability) then
     raise EGMImapException.ObjError(GMFormat(RStrCapabilityNotSupported, [ProtocolDisplayName, ACapability]), Self, ACallingName);
end;

procedure TGMImapClient.ClearServerCapabilities;
begin
  ServerCapabilities.Clear;
  SetLength(FServerAuthSchemes, 0);
end;

function TGMImapClient.UpdateCapabilities(const ACapabilities: TGMString): Boolean;
var chPos: PtrInt; token: TGMString;
begin
  if Length(ACapabilities) <= 0 then begin Result := False; Exit; end; // <- Early Fast Exit

  chPos := 1;
  token := GMNextWord(chPos, ACapabilities, ' ');

  if not GMSameText(token, 'CAPABILITY') then Result := False else
   begin
    Result := True;
    ClearServerCapabilities;
    repeat
     token := GMNextWord(chPos, ACapabilities, ' ');
     if length(token) > 0 then ServerCapabilities.Add(TGMNameObj.Create(token));
     //
     // Keep order of auth schemes send by the server in FServerAuthSchemes (ServerCapabilities list will be alpha sorted!)
     //
     if GMIsPrefixStr('AUTH=', token) then GMAddStrToArray(Copy(token, 6, Length(token)-5), FServerAuthSchemes);
    until Length(token) <= 0;
   end;
end;

procedure TGMImapClient.ProcessOkResponse(AServerResponse: PGMImapServerResponse);
begin
  if (AServerResponse = nil) or (AServerResponse.ResponseKind <> irkOk) then Exit;

  if UpdateCapabilities(AServerResponse.OptionalResposeCodeStr) then Exit; // <- Note: EXIT Here!

  ParseStatusCounters(AServerResponse.OptionalResposeCodeStr, @FSelectedMailbox);
end;

procedure TGMImapClient.ProcessUntaggedResponse(AServerResponse: PGMImapServerResponse; const AResponseDataDestinations: PGMImapResponseDataDestinations);
begin
  if AServerResponse = nil then Exit;

  if not (cmdUntagged in AServerResponse.AllowedTags) then
     raise EGMImapException.ObjError(GMFormat(RstrCommandTagNotAllowed, ['Untagged response', AServerResponse.ResponseTagStr]), Self, {$I %CurrentRoutine%});

  case AServerResponse.ResponseKind of
   irkOk:         ProcessOkResponse(AServerResponse);
   irkBye:        FServerWantsDisconnect := True;
   irkPreAuth:    FState := istAuthenticated;
   irkCapability: UpdateCapabilities(AServerResponse.ResponseToken + ' ' + AServerResponse.MsgText);
   irkStatus:     if AResponseDataDestinations <> nil then ParseImapStatusResponse(AServerResponse.MsgText, AResponseDataDestinations.PStatusResponse);

   irkList:       if (AResponseDataDestinations <> nil) and not AResponseDataDestinations.EnumCanceled then
                     AResponseDataDestinations.EnumCanceled := not ParseImapListResonse(AServerResponse.MsgText, AResponseDataDestinations.EnumSink, AResponseDataDestinations.EnumParam);

   irkExists:     FSelectedMailbox.Counter[isvkMessages] := AServerResponse.Number;
   irkRecent:     FSelectedMailbox.Counter[isvkRecent] := AServerResponse.Number;
   irkFlags:      FSelectedMailbox.SystemFlags := ParseImapFlagsResonse(AServerResponse.MsgText);
   irkFetch:      ParseUntaggedFetchResponse(AServerResponse.MsgText, AResponseDataDestinations.EnumSink, AResponseDataDestinations.EnumParam);
//                if (AResponseDataDestinations <> nil) and (AResponseDataDestinations.PStatusResponse <> nil) then
//                   AResponseDataDestinations.PStatusResponse.SystemFlags := ParseImapFlagsResonse(AServerResponse.MsgText);
  end;
end;

function TGMImapClient.ReadResponses(const ACommandTag: TGMString; const AResponseDataDestinations: PGMImapResponseDataDestinations): TGMImapServerResponse;
var responseLine: TGMString; ch: TGMChar; command: IGMImapCommand; // response: TGMImapServerResponse;
  procedure CheckSingleCharTag;
  begin
    if Length(Result.ResponseTagStr) <> 1 then raise EGMImapException.ObjError(GMFormat(RStrInvalidCmdTag, [Result.ResponseTagStr]) + ' ' + RStrFromServer, Self, {$I %CurrentRoutine%});
  end;

  function ReadImapResponseLine: AnsiString;
  var leave: Boolean; line: AnsiString; pChNumStart, pChNumEnd: PAnsiChar; moreCharCnt: PtrInt;
  begin
    Result := ''; line := ''; moreCharCnt := -1;
    repeat
     leave := True;
     line := ReadResponseLine(FTransportLayer);

     if (moreCharCnt >= 0) and (Length(line) <> moreCharCnt) then
        raise EGMImapException.ObjError(GMFormat(RStrInvalidContinuationLineLength, [Length(line), moreCharCnt]), Self, {$I %CurrentRoutine%});

     //moreCharCnt := -1;
     pChNumEnd := GMStrCRLScanA(PAnsiChar(line) + Length(line) - 1, ' ', Length(line));

     if (pChNumEnd <> nil) and (pChNumEnd^ = '}') then
      begin
       pChNumStart := GMStrRLScanA(pChNumEnd, '{', pChNumEnd - PAnsiChar(line));
       if pChNumStart = nil then raise EGMImapException.ObjError(RStrMissingContinuationNumStart, Self, {$I %CurrentRoutine%});
       moreCharCnt := GMStrToInt(Copy(line, pChNumStart - PAnsiChar(line) + 2, pChNumEnd - pChNumStart - 1));
       System.Delete(line, pChNumStart - PAnsiChar(line) + 1, PAnsiChar(line) - pChNumStart + Length(line));
       leave := False;
      end;

     Result := Result + line;
    until leave;
  end;
begin
  try
   repeat
    responseLine := GMUtf8ToString(ReadImapResponseLine); // <- interpret any octet > 127 as Utf-8
    if Length(responseLine) <= 0 then Break;
    vfGMTrace(responseLine, ProtocolDisplayName);

    Result := ParseImapServerResponseLine(responseLine);

    if Length(Result.ResponseTagStr) <= 0 then Break;

    ch := Result.ResponseTagStr[1];
    case ch of
     '*': begin // <- uniliteral message from server
           CheckSingleCharTag;
           ProcessUntaggedResponse(@Result, AResponseDataDestinations);
          end;

     '+': begin // <- current command continuation
           CheckSingleCharTag;
           Break;              // <- NOTE: Leave the loop here (break)!
          end;

     else
      begin
       command := CheckFindCommandInProgress(Result.ResponseTagStr, True);
       if command <> nil then command.ProcessCmdResponse(Self, Result); // Result
      end;
    end;
   until (Length(ACommandTag) <= 0) or GMSameText(Result.ResponseTagStr, ACommandTag); // or (Result.ResponseKind = irkBye);
         // ((FTransportLayerSocket <> nil) and not FTransportLayerSocket.IsDataAvailable);
  finally
   if FServerWantsDisconnect then DisconnectTransportLayer;
  end;
end;

function TGMImapClient.ExecCommand(const ACommand: TGMString; const AResponseDataDestinations: PGMImapResponseDataDestinations;
                                   ACommandClass: TGMImapCommandClass): TGMImapServerResponse;
var cmdTag, cmdLine: AnsiString; cmd: IGMImapCommand;
begin
//ClearImapServerResponse(Result);
  if (Length(ACommand) <= 0) then begin ClearImapServerResponse(Result); Exit; end;
  if not ReconnectIfDisconnected then raise EGMImapException.ObjError(RStrImapNotConnected, Self, 'ExecCommand("'+ACommand+'")');
  if FTransportLayer = nil then Exit;

  if ACommandClass = nil then ACommandClass := TGMImapCommand;

  Result.CommandTagStr := BuildNextCmdTag;
  cmdTag := Result.CommandTagStr;
  cmdLine := cmdTag + ' ' + ACommand + CRLF;

  if GMSameText('LOGIN', GMFirstWord(ACommand, cWhiteSpace)) then
    vfGMTrace(cStrCommand + ': ' + cmdTag + ' LOGIN ' + cStrHidden, ProtocolDisplayName)
  else
    vfGMTrace(cStrCommand + ': ' + cmdLine, ProtocolDisplayName);

  cmd := ACommandClass.Create(cmdTag, ACommand, True);
  CommandsInProgress.Add(cmd);
  GMSafeIStreamWrite(FTransportLayer, PAnsiChar(cmdLine), Length(cmdLine), ClassName + '.' + ACommand);
  Result := ReadResponses(cmdTag, AResponseDataDestinations);
end;

function TGMImapClient.StartCommand(const ACommand: TGMString): RCommandResponse;
var cmdResponse: TGMImapServerResponse;
begin
  cmdResponse := ExecCommand(ACommand);
  Result.CommandId := cmdResponse.CommandTagStr;
  Result.ResponseMsg := ResponseMsgFromServerResponse(cmdResponse);
end;

function TGMImapClient.ContinueCommand(const ACommandID: TGMString; AClientData: AnsiString): TGMString;
var crlfLen: Integer;
begin
  crlfLen := Length(CRLF);
  if (Length(AClientData) >= crlfLen) and (Copy(AClientData, Length(AClientData) - crlfLen + 1, crlfLen) <> CRLF) then AClientData := AClientData + CRLF;

  vfGMTrace(AClientData, ProtocolDisplayName);

  GMSafeIStreamWrite(FTransportLayer, PAnsiChar(AClientData), Length(AClientData), ClassName + '.ContinueCommand');
  Result := ResponseMsgFromServerResponse(ReadResponses(ACommandID));
end;

procedure TGMImapClient.NOOP;
begin
  ExecCommand('NOOP');
end;

function TGMImapClient.Capability: IGMIntfCollection;
begin
  ExecCommand('CAPABILITY');
  Result := ServerCapabilities;
end;

procedure TGMImapClient.Authenticate(const AUserName, APassword: TGMString; const AAuthHandlerClass: TGMSASLClientAuthenticationHandlerClass);
var authHandler: IGMSASLClientAuthenticationHandler;
begin
  if AAuthHandlerClass = nil then authHandler := ChooseAuthenticationHandler(FServerAuthSchemes) else
   begin
    authHandler := AAuthHandlerClass.Create(True);
    if not authHandler.IsEnabled(Self) then raise EGMImapException.ObjError(GMFormat(RStrAuthschemeNotAllowed, [authHandler.Name]), Self, {$I %CurrentRoutine%});
   end;

  if authHandler = nil then raise EGMImapException.ObjError(RStrNoCommonAuthScheme, Self, {$I %CurrentRoutine%});

  authHandler.ExecuteAuthentification(Self, AUserName, APassword);
  FState := istAuthenticated;
  if ServerCapabilities.IsEmpty then Capability; // <- If Server has nor sent untagged CAPABILITY response to authentication command
end;

//procedure TGMImapClient.Login(const AUserName, APassword: TGMString);
//begin
////if FState >= istAuthenticated then Exit;
//if ServerHasCapability('LOGINDISABLED') then raise EGMImapException.ObjError(RStrLoginDisabled, Self, 'Login');
//if not ServerHasCapability('AUTH=LOGIN') then raise EGMImapException.ObjError(RStrLoginCommandNotSupported, Self, 'Login');
//ClearServerCapabilities;
//ExecCommand('LOGIN ' + QuoteImapNameIfNeeded(AUserName) + ' ' + QuoteImapNameIfNeeded(APassword));
//FState := istAuthenticated;
//if ServerCapabilities.IsEmpty then Capability; // <- If Server has nor sent untagged CAPABILITY response to LOGIN command
//end;

procedure TGMImapClient.Create_(const AMailboxName: TGMString);
begin
  ExecCommand('CREATE ' + EncodeMailboxName(AMailboxName));
end;

procedure TGMImapClient.Delete(const AMailboxName: TGMString);
begin
  ExecCommand('DELETE ' + EncodeMailboxName(AMailboxName));
end;

procedure TGMImapClient.Rename(const AExistingMailboxName, ANewMailboxName: TGMString);
begin
  ExecCommand('RENAME ' + EncodeMailboxName(AExistingMailboxName) + ' ' + EncodeMailboxName(ANewMailboxName));
end;

procedure TGMImapClient.Examine(const AMailboxName: TGMString);
begin
  ExecCommand('EXAMINE ' + EncodeMailboxName(AMailboxName));
  FSelectedMailbox.MailBoxName := AMailboxName;
  FState := istSelected;
end;

procedure TGMImapClient.Select(const AMailboxName: TGMString);
begin
  ExecCommand('SELECT ' + EncodeMailboxName(AMailboxName));
  FSelectedMailbox.MailBoxName := AMailboxName;
  FState := istSelected;
end;

procedure TGMImapClient.List(const AMailboxPath, AMailboxName: TGMString; const AEnumSink: IUnknown; const AEnumParam: PtrInt);
var dataDests: TGMImapResponseDataDestinations;
begin
  dataDests := GMAssignResponseDataDestinations(AEnumSink, AEnumParam);
  ExecCommand('LIST ' + EncodeMailboxName(AMailboxPath) + ' ' + EncodeMailboxName(AMailboxName), @dataDests);
end;

function TGMImapClient.Status(const AMailboxName: TGMString; const AMailBoxCounterKinds: TGMImapMailboxCounterKinds): TGMImapMailboxCounters;
var argStr: TGMString; imck: TGMImapMailboxCounterKind; dataDests: TGMImapResponseDataDestinations;
begin
  ResetMailBoxCounters(Result);
  Result.MailBoxName := AMailboxName;

  argStr := '';
  for imck := Low(imck) to High(imck) do
    if imck in AMailBoxCounterKinds then argStr := GMStringJoin(argStr, ' ', cGMMailBoxCounterKindToken[imck]);

  dataDests := GMAssignResponseDataDestinations(nil, 0, @Result);
  ExecCommand('STATUS ' + EncodeMailboxName(AMailboxName) + ' (' + argStr + ')', @dataDests);
end;

procedure TGMImapClient.Fetch(const ADataItems: TGMString; const AEnumSink: IInterface; const AEnumParam: PtrInt);
var dataDests: TGMImapResponseDataDestinations;
begin
  dataDests := GMAssignResponseDataDestinations(AEnumSink, AEnumParam);
  ExecCommand('FETCH ' + ADataItems, @dataDests);
end;

procedure TGMImapClient.Close;
begin
  ExecCommand('CLOSE');
  FState := istAuthenticated;
end;

procedure TGMImapClient.Expunge;
begin
  ExecCommand('EXPUNGE');
end;

procedure TGMImapClient.Logout;
begin
  if FState > istNotConnected then
   try
    ExecCommand('LOGOUT'); // , TGMImapCommandLogout
   finally
    DisconnectTransportLayer;
    ResetMailBoxCounters(FSelectedMailbox);
   end;
end;

{$IFDEF TLS_SUPPORT}
procedure TGMImapClient.StartTLS;
const cStrCmdStartTLS = 'STARTTLS';
begin
  CheckServerHasCapability(cStrCmdStartTLS);
  ClearServerCapabilities;
  ExecCommand(cStrCmdStartTLS); // , TGMImapCommandStartTLS
  if not IsTransportLayerConnected then Exit;
  ExecuteTLSNegotiation;
  if ServerCapabilities.IsEmpty then Capability; // <- RFC 3501 recommends to ask for ServerCapabilities again after TLS negotiation!
                                                 //    If Server has nor sent untagged CAPABILITY response to STARTTLS command.
end;
{$ENDIF}


initialization

  vCSCreateServerResponseDescs := TGMCriticalSection.Create;
  vCSCreateSASLAuthHandlers := TGMCriticalSection.Create;

end.