clmailmessage.pas

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

  RegisterField('X-MSMail-Priority');
  RegisterField('X-MimeOLE');
  RegisterField('Reply-To');
  RegisterField('Disposition-Notification-To');
  RegisterField('Message-ID');
  RegisterField('MIME-Version');
  RegisterField('Newsgroups');
  RegisterField('References');
end;

procedure TclMailMessage.ParseExtraFields(AHeader, AKnownFields, AExtraFields: TStrings);
var
  i: Integer;
  s: string;
  FieldList: TStrings;
begin
  FieldList := TStringList.Create();
  try
    AExtraFields.Clear();

    GetHeaderFieldList(0, AHeader, FieldList);

    for i := 0 to FieldList.Count - 1 do
    begin
      if (FindInStrings(AKnownFields, FieldList[i]) < 0) then
      begin
        s := system.Copy(AHeader[Integer(FieldList.Objects[i])], 1, Length(FieldList[i]));
        AExtraFields.Add(s + ': ' + GetHeaderFieldValue(AHeader, FieldList, i));
      end;
    end;
  finally
    FieldList.Free();
  end;
end;
    
function TclMailMessage.ParseDate(ASource, AFieldList: TStrings): TDateTime;
var
  ind: Integer;
  s: string;
begin
  Result := Now();
  s := GetHeaderFieldValue(ASource, AFieldList, 'Date');
  if (s <> '') then
  begin
    Result := MailTimeToDateTime(DecodeField(s, CharSet));
  end else
  begin
    s := GetHeaderFieldValue(ASource, AFieldList, 'Received');
    ind := RTextPos(';', s);
    if (ind > 0) then
    begin
      Result := MailTimeToDateTime(DecodeField(Trim(System.Copy(s, ind + 1, 1000)), CharSet));
    end;
  end;
end;

procedure TclMailMessage.InternalAssignBodies(ASource: TStrings);
var
  i: Integer;
begin
  if (FBoundary = '') then
  begin
    GenerateBoundary();
  end;
  for i := 0 to FBodies.Count - 1 do
  begin
    if (MessageFormat <> mfUUencode) and IsMultiPartContent then
    begin
      ASource.Add('--' + Boundary);
      AssignBodyHeader(ASource, Bodies[i]);
      ASource.Add('');
    end;

    AddBodyToSource(ASource, Bodies[i]);

    if IsMultiPartContent then
    begin
      ASource.Add('');
    end;
  end;
  if (MessageFormat <> mfUUencode) and IsMultiPartContent then
  begin
    ASource.Add('--' + Boundary + '--');
  end;
end;

procedure TclMailMessage.AssignBodyHeader(ASource: TStrings; ABody: TclMessageBody);
begin
  ABody.AssignBodyHeader(ASource);
end;

function TclMailMessage.CreateBody(ABodies: TclMessageBodies;
  const AContentType, ADisposition: string): TclMessageBody;
begin
  if (system.Pos('multipart/', LowerCase(AContentType)) = 1) then
  begin
    Result := TclMultipartBody.Create(ABodies);
  end else
  if (system.Pos('image/', LowerCase(AContentType)) = 1) then
  begin
    Result := TclImageBody.Create(ABodies);
  end else
  if (LowerCase(ADisposition) = 'attachment')
    or (system.Pos('application/', LowerCase(AContentType)) = 1)
    or (system.Pos('message/', LowerCase(AContentType)) = 1)
    or (system.Pos('audio/', LowerCase(AContentType)) = 1)
    or (system.Pos('video/', LowerCase(AContentType)) = 1) then
  begin
    Result := TclAttachmentBody.Create(ABodies);
  end else
  begin
    Result := TclTextBody.Create(ABodies);
  end;
end;

function TclMailMessage.ParseBodyHeader(AStartFrom: Integer; ASource: TStrings): TclMessageBody;
var
  ContType, Disposition: string;
  FieldList: TStrings;
  bodyPos: Integer;
begin
  FieldList := TStringList.Create();
  try
    bodyPos := GetHeaderFieldList(AStartFrom, ASource, FieldList);
    ContType := GetHeaderFieldValue(ASource, FieldList, 'Content-Type');
    Disposition := GetHeaderFieldValue(ASource, FieldList, 'Content-Disposition');
    Result := CreateBody(Bodies, GetHeaderFieldValueItem(ContType, ''), GetHeaderFieldValueItem(Disposition, ''));
    Result.ParseBodyHeader(bodyPos + 1, ASource, FieldList);
  finally
    FieldList.Free();
  end;
end;

procedure TclMailMessage.AddBodyToSource(ASource: TStrings; ABody: TclMessageBody);
var
  Src: TStream;
  s: string;
begin
  if (MessageFormat = mfUUencode) and (ABody is TclAttachmentBody) then
  begin
    ASource.Add('begin 600 ' + ExtractFileName(TclAttachmentBody(ABody).FileName));
  end;
  Src := ABody.GetData();
  try
    SetString(s, nil, Src.Size);
    Src.Read(Pointer(s)^, Src.Size);
    AddTextStr(ASource, s);
  finally
    Src.Free();
  end;
  if (MessageFormat = mfUUencode) and (ABody is TclAttachmentBody) then
  begin
    ASource.Add('end');
  end;
end;

procedure TclMailMessage.AfterAddData(ABody: TclMessageBody; AEncodedLines: Integer);
begin
  if (ABody <> nil) and (FDataStream.Size > 0) then
  begin
    try
      FDataStream.Position := 0;
      ABody.AddData(FDataStream, AEncodedLines);
    finally
      FDataStream.Clear();
    end;
  end;
end;

procedure TclMailMessage.GetBodyFromSource(const ASource: string);
begin
  FDataStream.Write(PChar(ASource)^, Length(ASource));
end;

function TclMailMessage.IsUUEBodyStart(const ALine: string; var AFileName: string): Boolean;
var
  ind: Integer;
  s: string;
begin
  AFileName := '';
  Result := (system.Pos('begin', LowerCase(ALine)) = 1);
  if Result then
  begin
    Result := False;
    ind := system.Pos(#32, ALine);
    if (ind > 0) then
    begin
      s := TrimLeft(system.Copy(ALine, ind + 1, 1000));
      ind := system.Pos(#32, s);
      Result := (ind > 0) and (StrToIntDef(Trim(system.Copy(s, 1, ind)), -1) > -1);
      if Result then
      begin
        AFileName := Trim(system.Copy(s, ind + 1, 1000));
      end;
    end;
  end;
end;

function TclMailMessage.IsUUEBodyEnd(const ALine: string): Boolean;
begin
  Result := (Trim(LowerCase(ALine)) = 'end');
end;

function TclMailMessage.CreateUUEAttachmentBody(ABodies: TclMessageBodies;
  const AFileName: string): TclAttachmentBody;
begin
  Result := TclAttachmentBody.Create(ABodies);
  Result.FileName := AFileName;
  Result.Encoding := cmUUEncode;
end;

procedure TclMailMessage.ParseBodies(ASource: TStrings);
  procedure ParseMultiPartBodies(ASource: TStrings);
  var
    i, StartBody: Integer;
    s: string;
    BodyItem: TclMessageBody;
  begin
    BodyItem := nil;
    StartBody := 0;
    s := '';
    for i := 0 to ASource.Count - 1 do
    begin
      if (system.Pos('--' + Boundary, ASource[i]) > 0) then
      begin
        if (BodyItem <> nil) and (i > StartBody) then
        begin
          GetBodyFromSource(s + #13#10);
        end;
        AfterAddData(BodyItem, i - StartBody);
        BodyItem := nil;
        if (system.Pos('--' + Boundary + '--', ASource[i]) = 0) then
        begin
          BodyItem := ParseBodyHeader(i, ASource);
          StartBody := ParseAllHeaders(i + 1, ASource, BodyItem.RawHeader);
          BodyItem.FRawBodyStart := StartBody + 1;
          ParseExtraFields(BodyItem.RawHeader, BodyItem.FKnownFields, BodyItem.ExtraFields);
          if (StartBody < ASource.Count - 1) then
          begin
            Inc(StartBody);
          end;
          s := ASource[StartBody];
        end;
      end else
      begin
        if (BodyItem <> nil) and (i > StartBody) then
        begin
          GetBodyFromSource(s + #13#10);
          s := ASource[i];
        end;
      end;
    end;
    if (BodyItem <> nil) then
    begin
      GetBodyFromSource(s + #13#10);
    end;
    AfterAddData(BodyItem, ASource.Count - 1 - StartBody);
  end;

  procedure ParseSingleBody(ASource: TStrings);
  var
    i, bodyStart: Integer;
    singleBodyItem, BodyItem: TclMessageBody;
    fileName: string;
  begin
    bodyStart := 0;
    BodyItem := nil;
    singleBodyItem := nil;
    for i := 0 to ASource.Count - 1 do
    begin
      if (ASource[i] = '') and (singleBodyItem = nil) then
      begin
        singleBodyItem := CreateSingleBody(ASource, Bodies);
        bodyStart := i;
        singleBodyItem.FRawBodyStart := bodyStart + 1;
      end else
      if (singleBodyItem <> nil) then
      begin
        if IsUUEBodyStart(ASource[i], fileName) then
        begin
          MessageFormat := mfUUencode;

          if (BodyItem <> nil) then
          begin
            AfterAddData(BodyItem, 0);
          end else
          begin
            AfterAddData(singleBodyItem, 0);
          end;
          BodyItem := CreateUUEAttachmentBody(Bodies, fileName);
        end else
        if (MessageFormat = mfUUencode) and IsUUEBodyEnd(ASource[i]) then
        begin
          AfterAddData(BodyItem, 0);
          BodyItem := nil;
        end else
        begin
          GetBodyFromSource(ASource[i] + #13#10);
        end;
      end;
    end;
    if (MessageFormat = mfUUencode) then
    begin
      AfterAddData(singleBodyItem, 0);
    end else
    begin
      AfterAddData(singleBodyItem, ASource.Count - 1 - bodyStart);
    end;
  end;

  procedure RemoveEmptySingleBody;
  var
    i: Integer;
  begin
    for i := Bodies.Count - 1 downto 0 do
    begin
      if (Bodies[i] is TclTextBody) and (Trim(TclTextBody(Bodies[i]).Strings.Text) = '') then
      begin
        Bodies.Delete(i);
      end;
    end;
  end;

begin
  FIsParse := True;
  try
    if IsMultiPartContent then
    begin
      ParseMultiPartBodies(ASource);
      if (Bodies.Count = 0) then
      begin
        ParseSingleBody(ASource);
        RemoveEmptySingleBody();
      end;
    end else
    begin
      ParseSingleBody(ASource);
      RemoveEmptySingleBody();
    end;
  finally
    FIsParse := False;
  end;
end;

procedure TclMailMessage.DoOnListChanged(Sender: TObject);
begin
  Update();
end;

constructor TclMailMessage.Create(AOwner: TComponent);
  procedure SetListChangedEvent(AList: TStringList);
  begin
    AList.OnChange := DoOnListChanged;
  end;
  
begin
  inherited Create(AOwner);
  FHeaderSource := TStringList.Create();

  FBodiesSource := TStringList.Create();

  FMessageSource := TStringList.Create();

  FDataStream := TMemoryStream.Create();
  FUpdateCount := 0;

  FBodies := TclMessageBodies.Create(Self);

  FBCCList := TStringList.Create();
  SetListChangedEvent(FBCCList as TStringList);

  FCCList := TStringList.Create();
  SetListChangedEvent(FCCList as TStringList);

  FToList := TStringList.Create();
  SetListChangedEvent(FToList as TStringList);

  FIncludeRFC822Header := True;

  FReferences := TStringList.Create();
  SetListChangedEvent(FReferences as TStringList);

  FNewsGroups := TStringList.Create();
  SetListChangedEvent(FNewsGroups as TStringList);

  FExtraFields := TStringList.Create();
  SetListChangedEvent(FExtraFields as TStringList);

  FKnownFields := TStringList.Create();
  RegisterFields();

  FRawHeader := TStringList.Create();

  FCharsPerLine := DefaultCharsPerLine;

  Clear();
end;

destructor TclMailMessage.Destroy;
begin
  FRawHeader.Free();
  FKnownFields.Free();
  FExtraFields.Free();
  FNewsGroups.Free();
  FReferences.Free();
  FToList.Free();
  FCCList.Free();
  FBCCList.Free();
  FBodies.Free();
  FDataStream.Free();
  FMessageSource.Free();
  FBodiesSource.Free();
  FHeaderSource.Free();
  inherited Destroy();
end;

procedure TclMailMessage.SetBCCList(const Value: TStrings);
begin
  FBCCList.Assign(Value);
end;

procedure TclMailMessage.SetBodies(const Value: TclMessageBodies);
begin
  FBodies.Assign(Value);
end;