climap4.pas

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

  Inc(FCommandTag);
  Result := GetLastCommandTag();
end;

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

procedure TclCustomImap4.CreateMailBox(const AName: string);
begin
  if (Trim(AName) = '') or (Trim(AName)[1] = MailBoxSeparator) then
  begin
    RaiseError(cImapInvalidMailboxName);
  end;
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('CREATE "%s"', [AName], [IMAP_OK]);
end;

procedure TclCustomImap4.DeleteMailBox(const AName: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('DELETE "%s"', [AName], [IMAP_OK]);
end;

procedure TclCustomImap4.RenameMailBox(const ACurrentName, ANewName: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('RENAME "%s" "%s"', [ACurrentName, ANewName], [IMAP_OK]);
end;

function TclCustomImap4.GetMessageFlags(AIndex: Integer): TclMailMessageFlags;
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('FETCH %d (FLAGS)', [AIndex], [IMAP_OK]);
  Result := ParseMessageFlags(IntToStr(AIndex), False);
  FCurrentMessage := AIndex;
end;

procedure TclCustomImap4.AppendMessage(const AMailBoxName: string; AFlags: TclMailMessageFlags);
begin
  AppendMessage(AMailBoxName, MailMessage, AFlags);
end;

procedure TclCustomImap4.AppendMessage(const AMailBoxName: string; AMessage: TclMailMessage;
  AFlags: TclMailMessageFlags);
begin
  if (AMessage = nil) then
  begin
    RaiseError(cInvalidArgument);
  end;
  AppendMessage(AMailBoxName, AMessage.MessageSource, AFlags);
end;

procedure TclCustomImap4.CopyMessage(AIndex: Integer;
  const ADestMailBox: string);
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('COPY %d "%s"', [AIndex, ADestMailBox], [IMAP_OK]);
  FCurrentMessage := AIndex;
end;

procedure TclCustomImap4.DeleteMessage(AIndex: Integer);
begin
  SetMessageFlags(AIndex, fmAdd, [mfDeleted]);
end;

procedure TclCustomImap4.ParseMailBoxes(AList: TStrings; const ACommand: string);
var
  i: Integer;
  s: string;
begin
  AList.Clear();
  for i := 0 to Response.Count - 1 do
  begin
    if (System.Pos(Format('* %s ', [UpperCase(ACommand)]), UpperCase(Response[i])) = 1) then
    begin
      ParseMailboxInfo(Response[i], FMailBoxSeparator, s);
      if (s <> '') then
      begin
        AList.Add(s);
      end;
    end;
  end;
end;

procedure TclCustomImap4.GetMailBoxes(AList: TStrings; const ACriteria: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('LIST "" "%s"', [ACriteria], [IMAP_OK]);
  ParseMailBoxes(AList, 'LIST');
end;

function TclCustomImap4.GetMessageSize(AIndex: Integer): Integer;
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('FETCH %d (RFC822.SIZE)', [AIndex], [IMAP_OK]);
  Result := ParseMessageSize(IntToStr(AIndex), False);
  FCurrentMessage := AIndex;
end;

procedure TclCustomImap4.GetSubscribedMailBoxes(AList: TStrings);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('LSUB "" "*"', [], [IMAP_OK]);
  ParseMailBoxes(AList, 'LSUB');
end;

procedure TclCustomImap4.RetrieveHeader(AIndex: Integer; AMessage: TclMailMessage);
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('FETCH %d (BODY.PEEK[HEADER])', [AIndex], [IMAP_OK]);
  ParseMessage(IntToStr(AIndex), AMessage, False);
  FCurrentMessage := AIndex;
end;

procedure TclCustomImap4.RetrieveHeader(AIndex: Integer);
begin
  RetrieveHeader(AIndex, MailMessage);
end;

procedure TclCustomImap4.RetrieveMessage(AIndex: Integer);
begin
  RetrieveMessage(AIndex, MailMessage);
end;

procedure TclCustomImap4.RetrieveMessage(AIndex: Integer; AMessage: TclMailMessage);
begin
  CheckMessageValid(AIndex);
  CheckConnection([csAuthenticated, csSelected]);

  FTotalBytesToReceive := 0;
  if Assigned(OnProgress) then
  begin
    FTotalBytesToReceive := GetMessageSize(AIndex);
  end;
  try
    SendTaggedCommand('FETCH %d (BODY.PEEK[])', [AIndex], [IMAP_OK]);
    if Assigned(OnProgress) then
    begin
      DoProgress(FTotalBytesToReceive, FTotalBytesToReceive);
    end;
  finally
    FTotalBytesToReceive := 0;
    Connection.OnProgress := nil;
  end;
  
  ParseMessage(IntToStr(AIndex), AMessage, False);
  FCurrentMessage := AIndex;
end;

procedure TclCustomImap4.WaitingResponse(const AOkResponses: array of Integer);
begin
  if (FTotalBytesToReceive > 0) then
  begin
    Connection.OnProgress := DoDataProgress;
    Connection.InitProgress(0, FTotalBytesToReceive);
  end;
  inherited WaitingResponse(AOkResponses);
end;

procedure TclCustomImap4.DoDataProgress(Sender: TObject; ABytesProceed, ATotalBytes: Int64);
begin
  DoProgress(ABytesProceed, ATotalBytes);
end;

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

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

procedure TclCustomImap4.SubscribeMailBox(const AName: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('SUBSCRIBE "%s"', [AName], [IMAP_OK]);
end;

procedure TclCustomImap4.UnsubscribeMailBox(const AName: string);
begin
  CheckConnection([csAuthenticated, csSelected]);
  SendTaggedCommand('UNSUBSCRIBE "%s"', [AName], [IMAP_OK]);
end;

procedure TclCustomImap4.SetAutoReconnect(const Value: Boolean);
begin
  if (FAutoReconnect <> Value) then
  begin
    FAutoReconnect := Value;
    Changed();
  end;
end;

function TclCustomImap4.GetResponseCode(const AResponse: string): Integer;
var
  s: string;
  ind: Integer;
begin
  Result := SOCKET_WAIT_RESPONSE;
  if (AResponse = '') then Exit;

  if (System.Pos('+ ', AResponse) = 1) or ('+' = Trim(AResponse)) then
  begin
    Result := IMAP_CONTINUE;
    Exit;
  end;

  ind := System.Pos(' ', AResponse);
  if (ind < 2) or (ind > Length(AResponse) - 1) then Exit;

  s := Trim(System.Copy(AResponse, ind + 1, Length(AResponse)));
  ind := System.Pos(' ', s);
  if (ind < 1) then
  begin
    ind := Length(s);
  end;

  if FIsTaggedCommand
    and (System.Pos(UpperCase(LastCommandTag), UpperCase(AResponse)) <> 1) then Exit;

  s := Trim(System.Copy(s, 1, ind));
  if (s = 'OK') then
  begin
    Result := IMAP_OK;
  end else
  if (s = 'NO') then
  begin
    Result := IMAP_NO;
  end else
  if (s = 'BAD') then
  begin
    Result := IMAP_BAD;
  end else
  if (s = 'PREAUTH') then
  begin
    Result := IMAP_PREAUTH;
  end else
  if (s = 'BYE') then
  begin
    Result := IMAP_BYE;
  end;
end;

procedure TclCustomImap4.RaiseError(const AMessage: string);
begin
  raise EclSocketError.Create(AMessage, -1);
end;

procedure TclCustomImap4.Logout;
begin
  if (ConnectionState in [csAuthenticated, csSelected]) then
  begin
    try
      SendTaggedCommand('LOGOUT', [], [IMAP_OK]);
    except
      on EclSocketError do ;
    end;
  end;
  FConnectionState := csNonAuthenticated;
end;

procedure TclCustomImap4.CheckConnection(AStates: array of TclImapConnectionState);
  function IsInState: Boolean;
  var
    i: Integer;
  begin
    for i := Low(AStates) to High(AStates) do
    begin
      if (ConnectionState = AStates[i]) then
      begin
        Result := True;
        Exit;
      end;
    end;
    Result := False;
  end;

begin
  if not IsInState() then
  begin
    if AutoReconnect then
    begin
      if not Active then
      begin
        Open();
      end else
      begin
        OpenImapSession();
      end;
    end else
    begin
      RaiseError(cSocketErrorConnect);
    end;
  end;
end;

destructor TclCustomImap4.Destroy;
begin
  FCurrentMailBox.Free();
  inherited Destroy();
end;

procedure TclCustomImap4.ParseSelectedMailBox(const AName: string);
  function GetLexemPos(const ALexem, AText: string; var APos: Integer): Boolean;
  begin
    APos := System.Pos(ALexem, AText);
    Result := APos > 0;
  end;

var
  i, ind: Integer;
  responseStr: string;
begin
  CurrentMailBox.Clear();
  CurrentMailBox.Name := AName;
  for i := 0 to Response.Count - 1 do
  begin
    responseStr := UpperCase(Response[i]);
    if GetLexemPos('EXISTS', responseStr, ind) then
    begin
      CurrentMailBox.ExistsMessages := StrToIntDef(Trim(System.Copy(responseStr, 3, ind - 3)), 0);
    end else
    if not GetLexemPos('FLAGS', responseStr, ind)
      and GetLexemPos('RECENT', responseStr, ind) then
    begin
      CurrentMailBox.RecentMessages := StrToIntDef(Trim(System.Copy(responseStr, 3, ind - 3)), 0);