climap4filehandler.pas

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

    begin
      FetchBody(path + AMessageFile, 'RFC822', '', AResponseItem);
    end else
    if ('RFC822.HEADER' = ARequest[i].Name) then
    begin
      FetchHeader(path + AMessageFile, 'RFC822.HEADER', '', AResponseItem);
    end else
    if ('RFC822.SIZE' = ARequest[i].Name) then
    begin
      k := GetLocalFileSize(path + AMessageFile);
      if (k > -1) then
      begin
        AResponseItem.MessageData := AResponseItem.MessageData + Format('RFC822.SIZE %d', [k]);
      end;
    end else
    if ('UID' = ARequest[i].Name) and (not AUseUID) then
    begin
      AResponseItem.MessageData := AResponseItem.MessageData + 'UID ' + GetMessageUID(AConnection, AMessageFile);
    end else
    if ('FLAGS' = ARequest[i].Name) then
    begin
      s := GetMessageFlags(AConnection, path, AMessageFile);
      AResponseItem.MessageData := AResponseItem.MessageData + 'FLAGS (' + s + ')';
    end else
    if ('ENVELOPE' = ARequest[i].Name) then
    begin
      AResponseItem.MessageData := AResponseItem.MessageData + 'ENVELOPE ('
        + FetchMessageEnvelope(path + AMessageFile) + ')';
    end else
    if ('BODYSTRUCTURE' = ARequest[i].Name) then
    begin
      AResponseItem.MessageData := AResponseItem.MessageData + 'BODYSTRUCTURE ('
        + FetchBodyStructure(path + AMessageFile) + ')';
    end else
    if ('INTERNALDATE' = ARequest[i].Name) then
    begin
      s := DateTimeToImapTime(GetMessageInternalDate(path + AMessageFile));
      AResponseItem.MessageData := AResponseItem.MessageData + 'INTERNALDATE "' + s + '"';
    end;
  end;
  if AUseUID and (Length(AResponseItem.MessageData) > 0) then
  begin
    AResponseItem.MessageData := 'UID ' + GetMessageUID(AConnection, AMessageFile) + #32 + AResponseItem.MessageData;
  end;
end;

procedure TclImap4FileHandler.DoFetchMessages(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMessageSet, ADataItems: string;
  AUseUID: Boolean; AResponse: TclImap4FetchResponseList; var Result: TclImap4MessageResult);
var
  i: Integer;
  path: string;
  targetList: TStrings;
  request: TclImap4FetchRequestList;
begin
  RefreshMailBoxInfo(AConnection);

  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AConnection.CurrentMailBox.Name));
  try
    targetList := TStringList.Create();
    request := TclImap4FetchRequestList.Create(TclImap4FetchRequestItem);
    try
      FillTargetList(AConnection, AMessageSet, AUseUID, targetList);
      request.Parse(ADataItems);
      AResponse.Clear();

      for i := 0 to targetList.Count - 1 do
      begin
        FetchMessage(AConnection, targetList[i], request, AUseUID, AResponse.Add());
      end;
    finally
      request.Free();
      targetList.Free();
    end;
    Result := msOk;
  except
    Result := msNo;
  end;
end;

procedure TclImap4FileHandler.DoStoreMessages(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMessageSet: string;
  AFlagsMethod: TclSetFlagsMethod; AFlags: TclMailMessageFlags; IsSilent: Boolean;
  AUseUID: Boolean; AResponse: TclImap4FetchResponseList; var Result: TclImap4MessageResult);
var
  i: Integer;
  path, s: string;
  targetList: TStrings;
  item: TclImap4FetchResponseItem;
begin
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AConnection.CurrentMailBox.Name));

  try
    targetList := TStringList.Create();
    try
      FillTargetList(AConnection, AMessageSet, AUseUID, targetList);

      AResponse.Clear();
      for i := 0 to targetList.Count - 1 do
      begin
        s := SetMessageFlags(AConnection, path, targetList[i], AFlagsMethod, AFlags);
        if not IsSilent then
        begin
          item := AResponse.Add();
          item.MessageID := GetMessageList(AConnection).IndexOf(targetList[i]) + 1;
          Assert(item.MessageID > 0);
          item.MessageData := 'FLAGS (' + s + ')';
        end;
      end;
    finally
      targetList.Free();
    end;
    Result := msOk;
  except
    Result := msNo;
  end;
end;

procedure TclImap4FileHandler.DoPurgeMessages(Sender: TObject;
  AConnection: TclImap4CommandConnection; IsSilent: Boolean; AMessageIDs: TStrings;
  var Result: TclImap4MessageResult);
var
  i, ind: Integer;
  path, uid: string;
  ini: TIniFile;
  list, msgList: TStrings;
  flags: TclMailMessageFlags;
begin
  AMessageIDs.Clear();
  
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AConnection.CurrentMailBox.Name));
  if not FileExists(path + MailBoxInfoFile) then
  begin
    Result := msNo;
    Exit;
  end;

  try
    ini := nil;
    list := nil;
    try
      ini := TIniFile.Create(path + MailBoxInfoFile);
      list := TStringList.Create();

      msgList := GetMessageList(AConnection);
      ini.ReadSection(cMessagesSection, list);
      for i := list.Count - 1 downto 0 do
      begin
        ParseMessageInfo(ini.ReadString(cMessagesSection, list[i], ''), uid, flags);
        if (mfDeleted in flags) then
        begin
          if DeleteFile(path + list[i]) and (not IsSilent) then
          begin
            ind := msgList.IndexOf(list[i]);
            if (ind > -1) then
            begin
              AMessageIDs.Add(IntToStr(ind + 1));
            end;
          end;
          ini.DeleteKey(cMessagesSection, list[i]);
        end;
      end;
    finally
      list.Free();
      ini.Free();
    end;
    Result := msOk;
  except
    Result := msNo;
  end;
end;

procedure TclImap4FileHandler.DoCanAppendMessage(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string;
  var Result: TclImap4MailBoxResult);
var
  path: string;
begin
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(AMailBox);

  if DirectoryExists(path) then
  begin
    Result := mrSuccess;
  end else
  begin
    Result := mrNotFound;
  end;
end;

procedure TclImap4FileHandler.DoMessageAppended(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string;
  AFlags: TclMailMessageFlags; AMessage: TStrings; var Result: TclImap4MailBoxResult);
var
  path, fileName: string;
begin
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(AMailBox);

  try
    fileName := GenMessageFileName(AConnection);
    AMessage.SaveToFile(path + fileName);

    if (AFlags <> []) then
    begin                 
      SetMessageFlags(AConnection, path, fileName, fmReplace, AFlags);
    end;
    Result := mrSuccess;
  except
    Result := mrAccessDenied;
  end;
end;

procedure TclImap4FileHandler.SetMailBoxDir(const Value: string);
begin
  FAccessor.Enter();
  try
    FMailBoxDir := Value;
  finally
    FAccessor.Leave();
  end;
end;

procedure TclImap4FileHandler.SetMailBoxInfoFile(const Value: string);
begin
  FAccessor.Enter();
  try
    FMailBoxInfoFile := Value;
  finally
    FAccessor.Leave();
  end;
end;

procedure TclImap4FileHandler.DoCreateConnection(Sender: TObject; var AConnection: TclCommandConnection);
begin
  AConnection := TclImap4FileCommandConnection.Create();
end;

function TclImap4FileHandler.GetCurrentCounter(AConnection: TclImap4CommandConnection): Integer;
var
  ini: TIniFile;
begin
  ini := TIniFile.Create(GetMailBoxPath(AConnection.UserName) + MailBoxInfoFile);
  try
    Result := ini.ReadInteger(cMailBoxSection, 'Counter', 1);
  finally
    ini.Free();
  end;
end;

function TclImap4FileHandler.GetNextCounter(AConnection: TclImap4CommandConnection): Integer;
var
  ini: TIniFile;
begin
  ini := TIniFile.Create(GetMailBoxPath(AConnection.UserName) + MailBoxInfoFile);
  try
    Result := ini.ReadInteger(cMailBoxSection, 'Counter', 1);
    ini.WriteInteger(cMailBoxSection, 'Counter', Result + 1);
  finally
    ini.Free();
  end;
end;

function TclImap4FileHandler.FetchMessageEnvelope(const AMessagePath: string): string;
var
  stream: TStream;
  msg: TStrings;
begin
  Result := '';
  if not FileExists(AMessagePath) then Exit;

  stream := nil;
  msg := nil;
  try
    stream := TFileStream.Create(AMessagePath, fmOpenRead or fmShareDenyWrite);
    msg := TStringList.Create();

    GetTopLines(stream, 0, msg);
    Result := GetMessageEnvelope(msg);
  finally
    msg.Free();
    stream.Free();
  end;
end;

const
  EncodingMap: array[TclEncodeMethod] of string = ('"7bit"', '"quoted-printable"', '"base64"', 'NIL', '"8bit"');

procedure TclImap4FileHandler.ExtractContentTypeParts(const AContentType: string; var AType, ASubType: string);
var
  ind: Integer;
begin
  AType := 'NIL';
  ASubType := 'NIL';

  if (AContentType = '') then Exit;

  ind := system.Pos('/', AContentType);
  if (ind > 0) then
  begin
    AType := '"' + system.Copy(AContentType, 1, ind - 1) + '"';
    ASubType := '"' + system.Copy(AContentType, ind + 1, 1000) + '"';
  end else
  begin
    AType := '"' + AContentType + '"';
  end;
end;

function TclImap4FileHandler.GetMimeBodySize(ABody: TclMessageBody): string;
var
  cntType, subType: string;
begin
  ExtractContentTypeParts(ABody.ContentType, cntType, subType);
  if SameText(cntType, '"text"') then
  begin
    Result := Format('%d %d ', [ABody.EncodedSize, ABody.EncodedLines]);
  end else
  begin
    Result := Format('%d ', [ABody.EncodedSize]);
  end;
end;

function TclImap4FileHandler.GetMimeBodyStructure(ABodies: TclMessageBodies): string;
var
  i: Integer;
  body: TclMessageBody;
  s, cntType, subType: string;
begin
  Result := '';

  for i := 0 to ABodies.Count - 1 do
  begin
    body := ABodies[i];

    if (ABodies.Count > 1) then
    begin
      Result := Result + '(';
    end;

    if (body is TclTextBody) then
    begin
      ExtractContentTypeParts(body.ContentType, cntType, subType);
      Result := Result + Format('%s %s ', [cntType, subType]);

      if (TclTextBody(body).CharSet <> '') then
      begin
        Result := Result + Format('("charset" "%s") ', [TclTextBody(body).CharSet]);
      end;
      
      Result := Result + 'NIL NIL ' + EncodingMap[body.Encoding] + ' ';
      Result := Result + GetMimeBodySize(body);
      Result := Result + 'NIL NIL NIL';
    end else
    if (body is TclAttachmentBody) then
    begin
      ExtractContentTypeParts(body.ContentType, cntType, subType);
      Result := Result + Format('%s %s ', [cntType, subType]);

      Result := Result + Format('("name" "%s") ', [TclAttachmentBody(body).FileName]);
      s := TclAttachmentBody(body).ContentID;
      if (s <> '') then
      begin
        if (s[1] <> '<') then
        begin
          s := '<' + s + '>';
        end;
        Result := Result + '"' + s + '" NIL ';
        Result := Result + EncodingMap[body.Encoding] + ' ';
        Result := Result + GetMimeBodySize(body);
        Result := Result + 'NIL NIL NIL'; 
      end else
      begin
        Result := Result + 'NIL NIL '+ EncodingMap[body.Encoding] + ' ';
        Result := Result + GetMimeBodySize(body);
        Result := Result + Format('NIL ("attachment" ("filename" "%s")) NIL', [TclAttachmentBody(body).FileName]);
      end;
    end else
    if (body is TclMultipartBody) then
    begin
      Result := Result + GetMimeBodyStructure(TclMultipartBody(body).Bodies);

      ExtractContentTypeParts(body.ContentType, cntType, subType);

      cntType := '';
      if (TclMultipartBody(body).ContentSubType <> '') then
      begin
        cntType := Format('"type" "%s" ', [TclMultipartBody(body).ContentSubType]);
      end;

      Result := Trim(Result) + Format(' %s (%s"boundary" "%s") NIL NIL',
        [subType, cntType, TclMultipartBody(body).Boundary]);
    end;
    
    if (ABodies.Count > 1) then
    begin
      Result := Result + ')';
    end;
  end;
end;

procedure TclImap4FileHandler.GetUueBodySize(AMessage: TStrings; var ASize, ALines: Integer);
var
  i: Integer;
  isBody: Boolean;
begin
  ASize := 0;
  ALines := 0;
  isBody := False;
  for i := 0 to AMessage.Count - 1 do
  begin
    if isBody then
    begin
      ASize := ASize + Length(AMessage[i]) + Length(#13#10);
    end else
    if (AMessage[i] = '') then
    begin
      isBody := True;
      ALines := i;
    end;
  end;
  if (ALines > 0) then
  begin
    ALines := AMessage.Count - ALines - 1;
  end;
end;

function TclImap4FileHandler.GetBodyStructure(AMessage: TStrings): string;
var
  msg: TclMailMessage;
  cntType, subType: string;
  size, lines: Integer;
begin
  msg := TclMailMessage.Create(nil);
  try
    msg.MessageSource := AMessage;

    if (msg.MessageFormat = mfUUencode) then
    begin
      GetUueBodySize(AMessage, size, lines);
      Result := Format('"TEXT" "PLAIN" NIL NIL NIL "7BIT" %d %d NIL NIL NIL', [size, lines]);
    end else
    begin
      Result := GetMimeBodyStructure(msg.Bodies);

      if (msg.Bodies.Count > 1) and (msg.Boundary <> '') then
      begin
        ExtractContentTypeParts(msg.ContentType, cntType, subType);

        cntType := '';
        if (msg.ContentSubType <> '') then
        begin
          cntType := Format('"type" "%s" ', [msg.ContentSubType]);
        end;

        Result := Trim(Result) + Format(' %s ("boundary" "%s") NIL NIL', [subType, msg.Boundary]);
      end;
    end;
  finally
    msg.Free();
  end;
end;

function TclImap4FileHandler.FetchBodyStructure(const AMessagePath: string): string;
var
  msg: TStrings;
begin
  Result := '';
  if not FileExists(AMessagePath) then Exit;

  msg := TStringList.Create();
  try
    msg.LoadFromFile(AMessagePath);
    Result := GetBodyStructure(msg);
  finally
    msg.Free();
  end;
end;

{ TclImap4FileCommandConnection }

constructor TclImap4FileCommandConnection.Create;
begin
  inherited Create();
  FMessages := TStringList.Create();
end;

destructor TclImap4FileCommandConnection.Destroy;
begin
  FMessages.Free();
  inherited Destroy();
end;

end.