climap4.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

    end else
    if GetLexemPos('[UNSEEN', responseStr, ind) then
    begin
      CurrentMailBox.FirstUnseen := StrToIntDef(Trim(System.Copy(responseStr, ind + Length('[UNSEEN'),
        System.Pos(']', responseStr) - ind - Length('[UNSEEN'))), 0);
    end else
    if GetLexemPos('[READ-WRITE]', responseStr, ind) then
    begin
      CurrentMailBox.ReadOnly := False;
    end else
    if GetLexemPos('[READ-ONLY]', responseStr, ind) then
    begin
      CurrentMailBox.ReadOnly := True;
    end else
    if not GetLexemPos('[PERMANENTFLAGS', responseStr, ind)
      and GetLexemPos('FLAGS', responseStr, ind) then
    begin
      CurrentMailBox.Flags := GetImapMessageFlagsByStr(System.Copy(responseStr, ind, TextPos(')', responseStr, ind) - ind));
    end else
    if GetLexemPos('[PERMANENTFLAGS', responseStr, ind) then
    begin
      CurrentMailBox.ChangeableFlags := GetImapMessageFlagsByStr(System.Copy(responseStr, ind, TextPos(')', responseStr, ind) - ind));
    end;
    if GetLexemPos('[UIDVALIDITY', responseStr, ind) then
    begin
      ind := ind + Length('[UIDVALIDITY');
      CurrentMailBox.UIDValidity := Trim(System.Copy(responseStr, ind, TextPos(']', responseStr, ind) - ind));
    end;
  end;
end;

procedure TclCustomImap4.ParseSearchMessages(AList: TStrings);
var
  i: Integer;
begin
  AList.Clear();
  for i := 0 to Response.Count - 1 do
  begin
    if (System.Pos('* SEARCH', UpperCase(Response[i])) = 1) then
    begin
      AList.Text := Trim(StringReplace(
        System.Copy(Response[i], Length('* SEARCH') + 1, MaxInt), ' ', #13#10, [rfReplaceAll]));
      Break;
    end;
  end;
end;

function TclCustomImap4.ParseMessageSize(const AMessageId: string; AIsUid: Boolean): Integer;
var
  i, ind: Integer;
  responseStr: string;
begin
  Result := 0;
  for i := 0 to Response.Count - 1 do
  begin
    responseStr := UpperCase(Response[i]);
    if (GetMessageId('FETCH', responseStr, AIsUid) = AMessageId) then
    begin
      ind := System.Pos('RFC822.SIZE ', responseStr);
      if (ind > 0) then
      begin
        Result := StrToIntDef(Trim(ExtractNumeric(responseStr, ind + Length('RFC822.SIZE '))), 0);
      end;
      Break;
    end;
  end;
end;

function TclCustomImap4.ParseMessageFlags(const AMessageId: string; AIsUid: Boolean): TclMailMessageFlags;
var
  i, ind: Integer;
  responseStr: string;
begin
  Result := [];
  for i := 0 to Response.Count - 1 do
  begin
    responseStr := UpperCase(Response[i]);
    if (GetMessageId('FETCH', responseStr, AIsUid) = AMessageId) then
    begin
      ind := System.Pos('FLAGS', responseStr);
      if (ind > 0) then
      begin
        Result := GetImapMessageFlagsByStr(System.Copy(responseStr, ind, TextPos(')', responseStr, ind) - ind));
      end;
      Break;
    end;
  end;
end;

procedure TclCustomImap4.PurgeMessages;
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('CLOSE', [], [IMAP_OK]);
  FCurrentMailBox.Clear();
  FConnectionState := csAuthenticated;
end;

procedure TclCustomImap4.ParseMessage(const AMessageId: string; AMessage: TclMailMessage; AIsUid: Boolean);
var
  i, msgSize, size: Integer;
begin
  if (Response.Count < 4) then Exit;

  msgSize := ExtractMessageSize(Response[0]);
  if (msgSize = 0) then Exit;

  Response.Delete(0);

  i := 0;
  size := 0;
  while (i < Response.Count) do
  begin
    size := size + Length(Response[i]) + Length(#13#10);
    if (size <= msgSize) then
    begin
      Inc(i);
    end else
    if (size - msgSize) < (Length(Response[i]) + Length(#13#10)) then
    begin
      Response[i] := system.Copy(Response[i], 1, Length(Response[i]) - (size - msgSize));
      Inc(i);
    end else
    begin
      Response.Delete(i);
    end;
  end;

  if (AMessage <> nil) then
  begin
    AMessage.Clear();
    AMessage.MessageSource := Response;
  end;
end;

function TclCustomImap4.GetMessageId(const ACommand, AResponseLine: string; AIsUid: Boolean): string;
var
  ind: Integer;
begin
  ind := System.Pos(#32 + ACommand, UpperCase(AResponseLine));
  Result := '0';
  if (ind < 4) then Exit;
  if AIsUid then
  begin
    ind := TextPos('UID ', AResponseLine, ind);
    if (ind > 0) then
    begin
      Result := ExtractNumeric(AResponseLine, ind + Length('UID '));
    end;
  end else
  begin
    Result := IntToStr(StrToIntDef(Trim(System.Copy(AResponseLine, 2, ind - 1)), 0));
  end;
end;

procedure TclCustomImap4.CheckMessageValid(AIndex: Integer);
begin
  if (AIndex < 1) then
  begin
    RaiseError(cMailMessageNoInvalid);
  end;
end;

function TclCustomImap4.GetLastCommandTag: string;
begin
  Result := Format('a%.4d', [FCommandTag]);
end;

procedure TclCustomImap4.SendTaggedCommand(const ACommand: string;
  const Args: array of const; const AOkResponses: array of Integer);
begin
  FIsTaggedCommand := True;
  try
    SendCommandSync(GetNextCommandTag() + #32 + ACommand, AOkResponses, Args);
  finally
    FIsTaggedCommand := False;
  end;
end;

procedure TclCustomImap4.UidDeleteMessage(const AUid: string);
begin
  UidSetMessageFlags(AUid, fmAdd, [mfDeleted]);
end;

procedure TclCustomImap4.UidCopyMessage(const AUid, ADestMailBox: string);
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('UID COPY %s "%s"', [AUid, ADestMailBox], [IMAP_OK]);
  FCurrentMessage := 0;
end;

procedure TclCustomImap4.UidSetMessageFlags(const AUid: string;
  AMethod: TclSetFlagsMethod; AFlags: TclMailMessageFlags);
const
  methodLexem: array[TclSetFlagsMethod] of string = ('', '+', '-');
var
  cmd: string;
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);
  cmd := GetStrByImapMessageFlags(AFlags);
  SendTaggedCommand('UID STORE %s %sFLAGS.SILENT (%s)',
    [AUid, methodLexem[AMethod], Trim(cmd)], [IMAP_OK]);
  FCurrentMessage := 0;
end;

function TclCustomImap4.UidGetMessageFlags(
  const AUid: string): TclMailMessageFlags;
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('UID FETCH %s (FLAGS)', [AUid], [IMAP_OK]);
  Result := ParseMessageFlags(AUid, True);
  FCurrentMessage := 0;
end;

function TclCustomImap4.UidGetMessageSize(const AUid: string): Integer;
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('UID FETCH %s (RFC822.SIZE)', [AUid], [IMAP_OK]);
  Result := ParseMessageSize(AUid, True);
  FCurrentMessage := 0;
end;

procedure TclCustomImap4.UidRetrieveMessage(const AUid: string;
  AMessage: TclMailMessage);
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);

  FTotalBytesToReceive := 0;
  if Assigned(OnProgress) then
  begin
    FTotalBytesToReceive := UidGetMessageSize(AUid);
  end;
  try
    SendTaggedCommand('UID FETCH %s (BODY.PEEK[])', [AUid], [IMAP_OK]);
    if Assigned(OnProgress) then
    begin
      DoProgress(FTotalBytesToReceive, FTotalBytesToReceive);
    end;
  finally
    FTotalBytesToReceive := 0;
    Connection.OnProgress := nil;
  end;

  ParseMessage(AUid, AMessage, True);
  FCurrentMessage := 0;
end;

procedure TclCustomImap4.UidRetrieveHeader(const AUid: string;
  AMessage: TclMailMessage);
begin
  CheckUidValid(AUid);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('UID FETCH %s (BODY.PEEK[HEADER])', [AUid], [IMAP_OK]);
  ParseMessage(AUid, AMessage, True);
  FCurrentMessage := 0;
end;

procedure TclCustomImap4.CheckUidValid(const AUid: string);
begin
  if (AUid = '') then
  begin
    RaiseError(cMailMessageUidInvalid);
  end;
  if StrToIntDef(AUid, 0) < 1 then
  begin
    RaiseError(cMailMessageUidInvalid);
  end;
end;

procedure TclCustomImap4.UidSearchMessages(const ASearchCriteria: string; AMessageList: TStrings);
begin
  CheckConnection([csSelected]);
  SendTaggedCommand('UID SEARCH %s', [ASearchCriteria], [IMAP_OK]);
  ParseSearchMessages(AMessageList);
end;

function TclCustomImap4.GetMessageUid(AIndex: Integer): string;
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('FETCH %d (UID)', [AIndex], [IMAP_OK]);
  Result := ParseMessageUid(AIndex);
  FCurrentMessage := AIndex;
end;

function TclCustomImap4.ParseMessageUid(AIndex: Integer): string;
begin
  if (Response.Count > 0) and
    (GetMessageId('FETCH', Response[0], False) = IntToStr(AIndex)) then
  begin
    Result := GetMessageId('FETCH', Response[0], True);
  end else
  begin
    Result := '';
  end;
end;

procedure TclCustomImap4.AppendMessage(const AMailBoxName: string;
  AMessage: TStrings; AFlags: TclMailMessageFlags);
var
  flags: string;
begin
  if (Trim(AMailBoxName) = '') then
  begin
    RaiseError(cInvalidArgument);
  end;
  CheckConnection([csAuthenticated, csSelected]);
  flags := GetStrByImapMessageFlags(AFlags);
  if (flags <> '') then
  begin
    flags := Format('(%s) ', [flags]);
  end;

  SendTaggedCommand('APPEND "%s" %s{%d}',
    [AMailBoxName, flags, Length(AMessage.Text)], [IMAP_CONTINUE]);

  SendMultipleLines(AMessage);
  SendCommandSync('', [IMAP_OK]);
end;

procedure TclCustomImap4.ExamineMailBox(const AName: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  try
    SendTaggedCommand('EXAMINE "%s"', [AName], [IMAP_OK]);
    ParseSelectedMailBox(AName);
    FConnectionState := csSelected;
  except
    on E: EclSocketError do
    begin
      FCurrentMailBox.Clear();
      FConnectionState := csAuthenticated;
      raise;
    end;
  end;
end;

procedure TclCustomImap4.Noop;
begin
  SendTaggedCommand('NOOP', [], [IMAP_OK]);
end;

procedure TclCustomImap4.StartTls;
begin
  SendTaggedCommand('STARTTLS', [], [IMAP_OK]);
  inherited StartTls();
end;

function TclCustomImap4.GetDefaultPort: Integer;
begin
  Result := cDefaultImapPort;
end;

end.