idmessage.pas

photo.163.com 相册下载器 多线程下载

    FGenerateBCCListInHeader: Boolean;
    FIsMsgSinglePartMime: Boolean;
    FExceptionOnBlockedAttachments: Boolean; // used in TIdAttachmentFile
    //
    function  FixUpMsgID(const AValue: String) : String;
    procedure DoInitializeISO(var VTransferHeader: TTransfer; var VHeaderEncoding: Char; var VCharSet: String); virtual;
    function  GetAttachmentEncoding: string;
    function  GetInReplyTo: String;
    function  GetUseNowForDate: Boolean;
    function  GetFrom: TIdEmailAddressItem;
    procedure SetAttachmentEncoding(const AValue: string);
    procedure SetBccList(const AValue: TIdEmailAddressList);
    procedure SetBody(const AValue: TIdStrings);
    procedure SetCCList(const AValue: TIdEmailAddressList);
    procedure SetEncoding(const AValue: TIdMessageEncoding);
    procedure SetExtraHeaders(const AValue: TIdHeaderList);
    procedure SetFrom(const AValue: TIdEmailAddressItem);
    procedure SetFromList(const AValue: TIdEmailAddressList);
    procedure SetHeaders(const AValue: TIdHeaderList);
    procedure SetInReplyTo(const AValue : String);
    procedure SetMsgID(const AValue : String);
    procedure SetNewsGroups(const AValue: TIdStrings);
    procedure SetReceiptRecipient(const AValue: TIdEmailAddressItem);
    procedure SetRecipients(const AValue: TIdEmailAddressList);
    procedure SetReplyTo(const AValue: TIdEmailAddressList);
    procedure SetSender(const AValue: TIdEmailAddressItem);
    procedure SetUseNowForDate(const AValue: Boolean);
    procedure InitComponent; override;
  public
    destructor Destroy; override;

    procedure AddHeader(const AValue: string);
    procedure Clear; virtual;
    procedure ClearBody;
    procedure ClearHeader;
    procedure GenerateHeader;
    procedure InitializeISO(var VTransferHeader: TTransfer;
     var VHeaderEncoding: Char; var VCharSet: String);
    function  IsBodyEncodingRequired: Boolean;
    function  DetermineIfMsgIsSinglePartMime: Boolean;
    function  IsBodyEmpty: Boolean;

    procedure LoadFromFile(const AFileName: string; const AHeadersOnly: Boolean = False);
    procedure LoadFromStream(AStream: TStream; const AHeadersOnly: Boolean = False);

    function  ExtractCharSet(AContentType: string): string;
    procedure ProcessHeaders;

    procedure SaveToFile(const AFileName : string; const AHeadersOnly: Boolean = False);
    procedure SaveToStream(AStream: TStream; const AHeadersOnly: Boolean = False);

    procedure DoCreateAttachment(const AHeaders: TIdStrings;
      var VAttachment: TIdAttachment); virtual;
    //
    property Flags: TIdMessageFlagsSet read FFlags write FFlags;
    property IsEncoded : Boolean read FIsEncoded write FIsEncoded;
    property MsgId: string read FMsgId write SetMsgID;
    property Headers: TIdHeaderList read FHeaders write SetHeaders;
    property MessageParts: TIdMessageParts read FMessageParts;
    property MIMEBoundary: TIdMIMEBoundary read FMIMEBoundary write FMIMEBoundary;
    property UID: String read FUID write FUID;
    property IsMsgSinglePartMime: Boolean read FIsMsgSinglePartMime write FIsMsgSinglePartMime;
  published
    //TODO: Make a property editor which drops down the registered coder types
    property AttachmentEncoding: string read GetAttachmentEncoding write SetAttachmentEncoding;
    property Body: TIdStrings read FBody write SetBody;
    property BccList: TIdEmailAddressList read FBccList write SetBccList;
    property CharSet: string read FCharSet write FCharSet;
    property CCList: TIdEmailAddressList read FCcList write SetCcList;
    property ContentType: string read FContentType write FContentType;
    property ContentTransferEncoding: string read FContentTransferEncoding
     write FContentTransferEncoding;
    property ContentDisposition: string read FContentDisposition write FContentDisposition;
    property Date: TDateTime read FDate write FDate;
    //
    property Encoding: TIdMessageEncoding read FEncoding write SetEncoding;
    property ExtraHeaders: TIdHeaderList read FExtraHeaders write SetExtraHeaders;
    property FromList: TIdEmailAddressList read FFromList write SetFromList;
    property From: TIdEmailAddressItem read GetFrom write SetFrom;
    property NewsGroups: TIdStrings read FNewsGroups write SetNewsGroups;
    property NoEncode: Boolean read FNoEncode write FNoEncode default ID_MSG_NODECODE;
    property NoDecode: Boolean read FNoDecode write FNoDecode default ID_MSG_NODECODE;
    property Organization: string read FOrganization write FOrganization;
    property Priority: TIdMessagePriority read FPriority write FPriority default ID_MSG_PRIORITY;
    property ReceiptRecipient: TIdEmailAddressItem read FReceiptRecipient write SetReceiptRecipient;
    property Recipients: TIdEmailAddressList read FRecipients write SetRecipients;
    property References: string read FReferences write FReferences;
    property InReplyTo : String read GetInReplyTo write SetInReplyTo;
    property ReplyTo: TIdEmailAddressList read FReplyTo write SetReplyTo;
    property Subject: string read FSubject write FSubject;
    property Sender: TIdEmailAddressItem read FSender write SetSender;
    property UseNowForDate: Boolean read GetUseNowForDate write SetUseNowForDate default ID_MSG_USENOWFORDATE;
    property LastGeneratedHeaders: TIdHeaderList read FLastGeneratedHeaders;
    property ConvertPreamble: Boolean read FConvertPreamble write FConvertPreamble;
    property ExceptionOnBlockedAttachments: Boolean read FExceptionOnBlockedAttachments write FExceptionOnBlockedAttachments default False;

    // Events
    property OnInitializeISO: TIdInitializeIsoEvent read FOnInitializeISO write FOnInitializeISO;
    property OnCreateAttachment: TIdCreateAttachmentEvent read FOnCreateAttachment write FOnCreateAttachment;
  End;

  TIdMessageEvent = procedure(ASender : TComponent; var AMsg : TIdMessage) of object;

  TIdStringMessageEvent = procedure(ASender : TComponent; const AString : String; var AMsg : TIdMessage) of object;

  EIdTextInvalidCount = class(EIdMessageException);

  // 2001-Oct-29 Don Siders
  EIdMessageCannotLoad = class(EIdMessageException);

const
  MessageFlags : array [mfAnswered..mfRecent] of String =
  ( '\Answered', {Do not Localize} //Message has been answered.
    '\Flagged', {Do not Localize} //Message is "flagged" for urgent/special attention.
    '\Deleted', {Do not Localize} //Message is "deleted" for removal by later EXPUNGE.
    '\Draft', {Do not Localize} //Message has not completed composition (marked as a draft).
    '\Seen', {Do not Localize} //Message has been read.
    '\Recent' ); {Do not Localize} //Message is "recently" arrived in this mailbox.

  INREPLYTO = 'In-Reply-To'; {Do not localize}

implementation

uses
  IdIOHandlerStream, IdGlobal,
  IdMessageCoderMIME, // Here so the 'MIME' in create will always suceed
  IdCharSets, IdGlobalProtocols, IdMessageCoder, IdResourceStringsProtocols,
  IdMessageClient, IdAttachmentFile,
  IdText;

{ TIdMIMEBoundary }

procedure TIdMIMEBoundary.Clear;
begin
  FBoundaryList.Clear;
  FParentPartList.Clear;
end;

function TIdMIMEBoundary.Count: integer;
begin
  Result := FBoundaryList.Count;
end;

constructor TIdMIMEBoundary.Create;
begin
  inherited;
  FBoundaryList := TIdStringList.Create;
  FParentPartList := TIdStringList.Create;
end;

destructor TIdMIMEBoundary.Destroy;
begin
  FreeAndNil(FBoundaryList);
  FreeAndNil(FParentPartList);
  inherited;
end;

class function TIdMIMEBoundary.FindBoundary(AContentType: string): string;
var
  s: string;
begin
  // Store in s and not Result because of Fetch semantics
  s := UpperCase(AContentType);
  {CC: Used to Fetch 'BOUNDARY=', but this failed for those with 'BOUNDARY ='}
  Fetch(s, 'BOUNDARY'); {do not localize}
  if Length(s) > 0 then begin
    s := Trim(s);
    if (Length(s) > 0) and (s[1] = '=') then begin       {do not localize}
      s := Copy(s, 2, MAXINT);
    end;
    {CC: Fix suggested by Juergen Haible - some clients add a space after the boundary,
    remove it by calling Trim(s)...}
    s := Trim(s);
    if (Length(s) > 0) and (s[1] = '"') then begin {do not localize}
      Delete(s, 1, 1);
      Result := Fetch(s, '"'); {do not localize}
    // Should never occur, and if so bigger problems but just in case we'll try
    end else begin
      Result := s;
    end;
  end else begin
    Result := s;
  end;
end;

function TIdMIMEBoundary.GetBoundary: string;
begin
  if FBoundaryList.Count > 0 then begin
    Result := FBoundaryList.Strings[0];
  end else begin
    Result := '';
  end;
end;

function TIdMIMEBoundary.GetParentPart: integer;
begin
  if FParentPartList.Count > 0 then begin
    Result := StrToInt(FParentPartList.Strings[0]);
  end else begin
    Result := -1;
  end;
end;

procedure TIdMIMEBoundary.Pop;
begin
  FBoundaryList.Delete(0);
  FParentPartList.Delete(0);
end;

procedure TIdMIMEBoundary.Push(ABoundary: string; AParentPart: integer);
begin
  {CC: Changed implementation to a simple stack}
  FBoundaryList.Insert(0, ABoundary);
  FParentPartList.Insert(0, IntToStr(AParentPart));
end;

{ TIdMessage }

procedure TIdMessage.AddHeader(const AValue: string);
begin
  FHeaders.Add(AValue);
end;

procedure TIdMessage.Clear;
begin
  ClearHeader;
  ClearBody;
end;

procedure TIdMessage.ClearBody;
begin
  MessageParts.Clear ;
  Body.Clear;
end;

procedure TIdMessage.ClearHeader;
begin
  CcList.Clear;
  BccList.Clear;
  Date := 0;
  FromList.Clear;
  NewsGroups.Clear;
  Organization := '';
  References := '';
  ReplyTo.Clear;
  Subject := '';
  Recipients.Clear;
  Priority := ID_MSG_PRIORITY;
  ReceiptRecipient.Text := '';
  ContentType := '';
  FCharSet := '';
  ContentTransferEncoding := '';
  ContentDisposition := '';
  FSender.Text := '';
  Headers.Clear;
  ExtraHeaders.Clear;
  FMIMEBoundary.Clear;
//  UseNowForDate := ID_MSG_USENOWFORDATE;
  Flags := [];
  MsgId := '';
  UID := '';
  FLastGeneratedHeaders.Clear;
  FEncoding := meDefault; {CC3: Changed initial encoding from meMIME to meDefault}
  FConvertPreamble := True;  {By default, in MIME, we convert the preamble text to the 1st TIdText part}
  FGenerateBCCListInHeader := False;  {Only set True by SaveToFile}
end;

procedure TIdMessage.InitComponent;
begin
  inherited;
  FBody := TIdStringList.Create;
  FRecipients := TIdEmailAddressList.Create(Self);
  FBccList := TIdEmailAddressList.Create(Self);
  FCcList := TIdEmailAddressList.Create(Self);
  FMessageParts := TIdMessageParts.Create(Self);
  FNewsGroups := TIdStringList.Create;
  FHeaders := TIdHeaderList.Create;
  FFromList := TIdEmailAddressList.Create(Self);
  FReplyTo := TIdEmailAddressList.Create(Self);
  FSender := TIdEmailAddressItem.Create(nil);
  FExtraHeaders := TIdHeaderList.Create;
  FReceiptRecipient := TIdEmailAddressItem.Create(nil);
  NoDecode := ID_MSG_NODECODE;
  FMIMEBoundary := TIdMIMEBoundary.Create;
  FLastGeneratedHeaders := TIdHeaderList.Create;
  Clear;
  FEncoding := meDefault;
end;

destructor TIdMessage.Destroy;
begin
  FreeAndNil(FBody);
  FreeAndNil(FRecipients);
  FreeAndNil(FBccList);
  FreeAndNil(FCcList);
  FreeAndNil(FMessageParts);
  FreeAndNil(FNewsGroups);
  FreeAndNil(FHeaders);
  FreeAndNil(FExtraHeaders);
  FreeAndNil(FFromList);
  FreeAndNil(FReplyTo);
  FreeAndNil(FSender);
  FreeAndNil(FReceiptRecipient);
  FreeAndNil(FMIMEBoundary);
  FreeAndNil(FLastGeneratedHeaders);
  inherited destroy;
end;

function  TIdMessage.IsBodyEmpty: Boolean;
//Determine if there really is anything in the body
var
  LN: integer;
  LOrd: integer;
begin
  Result := False;
  for LN := 1 to Length(Body.Text) do begin
    LOrd := Ord(Body.Text[LN]);
    if ((LOrd <> 13) and (LOrd <> 10) and (LOrd <> 9) and (LOrd <> 32)) then begin
      Exit;
    end;
  end;
  Result := True;
end;

function  TIdMessage.DetermineIfMsgIsSinglePartMime: Boolean;
//Sets up FIsMsgSinglePartMime.
begin
  FIsMsgSinglePartMime := False;
  Result := FIsMsgSinglePartMime;
  if ((Encoding <> meMIME) or (MessageParts.Count <> 1) or (IsBodyEmpty = False)) then begin
    Exit;
  end;
  FIsMsgSinglePartMime := True;
  Result := FIsMsgSinglePartMime;
end;

procedure TIdMessage.GenerateHeader;
var
  ISOCharset: string;
  HeaderEncoding: Char;
  TransferHeader: TTransfer;
  LN: Integer;
  LEncoding: string;
  LMIMEBoundary: string;
begin
  MessageParts.CountParts;
  {CC2: If the encoding is meDefault, the user wants us to pick an encoding mechanism:}
  if Encoding = meDefault then begin
    if MessageParts.Count = 0 then begin
      {If there are no attachments, we want the simplest type, just the headers
      followed by the message body: mePlainText does this for us}
      Encoding := mePlainText;
    end else begin
      {If there are any attachments, default to MIME...}
      Encoding := meMIME;
    end;
  end;
  for LN := 0 to MessageParts.Count-1 do begin
    {Change any encodings we don't know to base64 for MIME and UUE for PlainText...}
    LEncoding := MessageParts[LN].ContentTransfer;
    if LEncoding <> '' then begin
      if Encoding = meMIME then begin
        if ( (TextIsSame(LEncoding, '7bit') = False) and                     {do not localize}
         (TextIsSame(LEncoding, '8bit') = False) and                         {do not localize}
         (TextIsSame(LEncoding, 'binary') = False) and                     {do not localize}
         (TextIsSame(LEncoding, 'base64') = False) and                       {do not localize}
         (TextIsSame(LEncoding, 'quoted-printable') = False) and             {do not localize}
         (TextIsSame(LEncoding, 'binhex40') = False)) then begin             {do not localize}
          MessageParts[LN].ContentTransfer := 'base64';                      {do not localize}
        end;
      end else begin  //mePlainText
        if ( (TextIsSame(LEncoding, 'UUE') = False) and                      {do not localize}
         (TextIsSame(LEncoding, 'XXE') = False)) then begin                  {do not localize}
          MessageParts[LN].ContentTransfer := 'UUE';                         {do not localize}
        end;
      end;
    end;
  end;
  {CC2: We dont support attachments in an encoded body.
  Change it to a supported combination...}
  if MessageParts.Count > 0 then begin
    if ((ContentTransferEncoding <> '') and
        (not TextIsSame(ContentTransferEncoding, '7bit')) and         {do not localize}
        (not TextIsSame(ContentTransferEncoding, 'binary')) and       {do not localize}
        (not TextIsSame(ContentTransferEncoding, '8bit'))) then begin {do not localize}
      ContentTransferEncoding := '';
    end;
  end;
  if Encoding = meMIME then begin
    //HH: Generate Boundary here so we know it in the headers
    LMIMEBoundary := IdMIMEBoundaryStrings.IndyMIMEBoundary;
    //CC: Moved this logic up from SendBody to here, where it fits better...
    if Length(ContentType) = 0 then begin
      //User has omitted ContentType.  We have to guess here, it is impossible
      //to determine without having procesed the parts.
      //See if it is multipart/alternative...
      if MessageParts.TextPartCount > 1 then begin
        if MessageParts.AttachmentCount > 0 then begin
          ContentType := 'multipart/mixed';    {do not localize}
        end else begin
          ContentType := 'multipart/alternative';   {do not localize}
        end;
      end else begin
        //Just one (or 0?) text part.
        if MessageParts.AttachmentCount > 0 then begin
          ContentType := 'multipart/mixed';    {do not localize}
        end else begin
          ContentType := 'text/plain';    {do not localize}
        end;
      end;
    end;
    TIdMessageEncoderInfo(MessageParts.MessageEncoderInfo).InitializeHeaders(Self);
  end;

  InitializeISO(TransferHeader, HeaderEncoding, ISOCharSet);
  LastGeneratedHeaders.Clear;

  if (FHeaders.Count > 0) then begin
    LastGeneratedHeaders.Assign(FHeaders);