mimemess_simail.pas

siMail, siMail, siMail, siMail

{==============================================================================|
| Project : Ararat Synapse                                       | 002.002.004 |
|==============================================================================|
| Content: MIME message object                                                 |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM From distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}
{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit mimemess_siMail;

interface

uses
  Classes, SysUtils,
  mimepart, synachar, synautil, mimeinln_siMail;

type TmailPriority = (mpLowest, mpLow, mpNormal, mpHigh, mpHighest);

type
  TMessHeader = class(TObject)
  private
    FFrom: string;
    FToList: TStringList;
    FCCList: TStringList;
    FSubject: string;
    FOrganization: string;
    FCustomHeaders: TStringList;
    FFullHeaders:TStringList;
    FDate: TDateTime;
    FXMailer: string;
    FCharsetCode: TMimeChar;
    FPriority: TmailPriority;
    FXNotification:String;
    FReplyTo: string;
    FXSignature: string;
    FXBCCList: TStringList;
    FXAttachList: TStringList;
    function BreakApart(line: String; maxLen: Integer): String;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure EncodeHeaders(const Value: TStrings);
    procedure DecodeHeaders(const Value: TStrings);
    function  FindHeader(Value: string): string;
    procedure FindHeaderList(Value: string; const HeaderList: TStrings);
  published
    property From: string read FFrom Write FFrom;
    property AttachList: TStringList read FXAttachList;
    property ToList: TStringList read FToList;
    property CCList: TStringList read FCCList;
    property Subject: string read FSubject Write FSubject;
    property Organization: string read FOrganization Write FOrganization;
    property CustomHeaders: TStringList read FCustomHeaders;
    property Date: TDateTime read FDate Write FDate;
    property XMailer: string read FXMailer Write FXMailer;
    property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
    property FullHeaders: TStringList read FFullHeaders;
    property Priority: TmailPriority read FPriority write FPriority;
    property ReplyTo:string read FReplyTo Write FReplyTo;
    property Notification:String read FXNotification write FXNotification;
    property BCCList: TStringList read FXBCCList;
    property Signature:String read FXSignature write FXSignature;
  end;

  TMimeMess = class(TObject)
  private
    FMessagePart: TMimePart;
    FLines: TStringList;
    FHeader: TMessHeader;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function AddPart(const PartParent: TMimePart): TMimePart;
    function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
    function AddPartText(const Value:String; const PartParent: TMimePart): TMimepart; overload;
    function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; overload;
    function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; overload;
    function AddPartHTML(const Value:String; const PartParent: TMimePart): TMimepart; overload;    
    function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
    function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
    function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
    function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
    function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
    function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
    procedure EncodeMessage;
    procedure DecodeMessage;
  published
    property MessagePart: TMimePart read FMessagePart;
    property Lines: TStringList read FLines;
    property Header: TMessHeader read FHeader;
  end;

implementation

{==============================================================================}

constructor TMessHeader.Create;
begin
  inherited Create;
  FToList := TStringList.Create;
  FCCList := TStringList.Create;
  FCustomHeaders := TStringList.Create;
  FFullHeaders := TStringList.Create;
  FXBCCList := TStringList.Create;
  FCharsetCode := UTF_8; //return unicode //GetCurCP;
  FXAttachList := TStringList.Create;
end;

destructor TMessHeader.Destroy;
begin
  FCustomHeaders.Free;
  FCCList.Free;
  FToList.Free;
  FFullHeaders.Free;
  FXBCCList.Free;
  FXAttachList.Free;
  inherited Destroy;
end;

{==============================================================================}

procedure TMessHeader.Clear;
begin
  FFrom := '';
  FToList.Clear;
  FCCList.Clear;
  FSubject := '';
  FOrganization := '';
  FCustomHeaders.Clear;
  FFullHeaders.Clear;
  FDate := 0;
  FXMailer := '';
  FPriority:=mpNormal;
  FXNotification:='';
  FReplyTo:='';
  FXBCCList.Clear;
  FXAttachList.Clear;
  FXSignature:='';
end;

procedure TMessHeader.EncodeHeaders(const Value: TStrings);
var
  n: Integer;
  s: string;
begin
  if FDate = 0 then
    FDate := Now;
  for n := FCustomHeaders.Count - 1 downto 0 do begin
    if FCustomHeaders[n] <> '' then
      Value.Insert(0, BreakApart(FCustomHeaders[n], 75));
  end;

    Value.Insert(0, 'X-Priority: ' + IntToStr(Integer(FPriority) + 1));
    case FPriority of
    mpHighest,mpHigh: begin
        Value.Insert(0, 'Priority: urgent');
        Value.Insert(0, 'X-MSMail-Priority: High');
    end;
(*    mpHigh: begin
    end;*)
    mpNormal: begin
        Value.Insert(0, 'Priority: Normal');
        Value.Insert(0, 'X-MSMail-Priority: Normal');
    end;
    mpLow,mpLowest: begin
        Value.Insert(0, 'Priority: non-urgent');
        Value.Insert(0, 'X-MSMail-Priority: Low');
    end;
(*    mpLowest: begin
    end*)
    end;
  if FXNotification <> '' then begin
    Value.Insert(0, 'Disposition-Notification-To: ' + InlineEmailEx(FXNotification, FCharsetCode));
    Value.Insert(0, 'Return-Receipt-Requested: ' + InlineEmailEx(FXNotification, FCharsetCode));
    Value.Insert(0, 'Return-Receipt-To: ' + InlineEmailEx(FXNotification, FCharsetCode));
    Value.Insert(0, 'Read-Receipt-To: ' + InlineEmailEx(FXNotification, FCharsetCode));
    Value.Insert(0, 'Registered-Mail-Reply-Requested-By: ' + InlineEmailEx(FXNotification, FCharsetCode));
    Value.Insert(0, 'X-Confirm-Reading-To: ' + InlineEmailEx(FXNotification, FCharsetCode));
  end;
  if FXMailer = '' then
    Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
  else
    Value.Insert(0, 'X-mailer: ' + FXMailer);
  Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
  if FOrganization <> '' then
    Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
  if FReplyTo <> '' then
    Value.Insert(0, 'Reply-To: ' + InlineEmailHdrEx(FReplyTo,'Reply-To: ', FCharsetCode));
  //CC:
  s := '';
  for n := 0 to FCCList.Count - 1 do begin
    if s = '' then
      s := InlineEmailHdrEx(FCCList[n],'CC: ', FCharsetCode) + #13#10
    else
      s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode) + #13#10;
  end;
  if s <> '' then
    Value.Insert(0, 'CC: ' + Copy(s,1,Length(s)-2));

  Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
  if FSubject <> '' then
    Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
  //To:
  s := '';
  for n := 0 to FToList.Count - 1 do begin
    if s = '' then
      s := InlineEmailHdrEx(FToList[n],'To: ', FCharsetCode) + #13#10
    else
      s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode) + #13#10;
  end;
  if s <> '' then
    Value.Insert(0, 'To: ' + Copy(s,1,Length(s)-2));

  Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
  //X-BCC:
  s:='';
  for n := 0 to FXBCCList.Count - 1 do begin
    if s = '' then
      s := InlineEmailHdrEx(FXBCCList[n],'X-BCC: ', FCharsetCode) + #13#10
    else
      s := s + ' , ' + InlineEmailEx(FXBCCList[n], FCharsetCode) + #13#10;
  end;
  if s <> '' then
    Value.Insert(0, 'X-BCC: ' + Copy(s,1,Length(s)-2));
  //X-Attachment:
  s:='';
  for n := 0 to FXAttachList.Count - 1 do begin
    if s = '' then
      s := InlineCodeHdrEx(FXAttachList[n],'X-Attachment: ', FCharsetCode) + #13#10
    else
      s := s + ' , ' + InlineCodeEx(FXAttachList[n], FCharsetCode) + #13#10;
  end;
  if s <> '' then
    Value.Insert(0, 'X-Attachment: ' + Copy(s,1,Length(s)-2));

  if FXSignature <> '' then
    Value.Insert(0, 'X-Signature: ' + InlineCodeEx(FXSignature, FCharsetCode));

end;

//all lines that are equal after decoding are encoded to UTF8 (just in case is someboy forget to
//specify encoding)
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
  s, t,t2: string;
  x: Integer;
  cp: TMimeChar;
  oldX,cpy:Integer;
  prioritySet:Boolean;
begin
  cp := FCharsetCode;
  prioritySet:=False;
  Clear;
  x := 0;
  oldX:=0;
  //while Value.Count > x do
  while True do
  begin
    if x >= Value.Count - 1 then Break;
    if Value.Strings[x] = '' then Break;

    if x <> 0 then oldX:=x+1;
    //if x <> 0 then oldX:=x;
    s := NormalizeHeader(Value, x);
    if x > Value.Count then
      Dec(x);
    //copy to full headers
    for cpy:=oldX to x do
        FFullHeaders.Add(Value.Strings[cpy]);
    if s = '' then
      Break;
    if Pos('X-MAILER:', UpperCase(s)) = 1 then
    begin
      s:=SeparateRight(s, ':');
      FXMailer := InlineDecode(s, cp);
      if s = FXMailer then
        FXMailer:=AnsiToUtf8(Trim(s));
      continue;
    end;
    if Pos('FROM:', UpperCase(s)) = 1 then
    begin
      s:=SeparateRight(s, ':');
      FFrom := InlineDecode(s, cp);
      if s = FFrom then
        FFrom:=AnsiToUtf8(Trim(s));
      continue;
    end;
    if Pos('SUBJECT:', UpperCase(s)) = 1 then
    begin
      s:=SeparateRight(s, ':');
      FSubject := InlineDecode(s, cp);
      if s = FSubject then
        FSubject:=AnsiToUtf8(Trim(s));
      continue;
    end;
    if Pos('ORGANIZATION:', UpperCase(s)) = 1 then
    begin
      s:=SeparateRight(s, ':');
      FOrganization := InlineDecode(s, cp);
      if s = FOrganization then
        FOrganization:=AnsiToUtf8(Trim(s));
      continue;
    end;
    if Pos('TO:', UpperCase(s)) = 1 then
    begin
      s := SeparateRight(s, ':');
      repeat
        t:=FetchEx(s, ',', '"');
        t2 := InlineDecode(t, cp);
        if t2 <> '' then begin
            if t2 = t then
                t2:=AnsiToUtf8(Trim(t2));
          FToList.Add(t2);
        end;
      until s = '';
      continue;
    end;
    if Pos('CC:', UpperCase(s)) = 1 then
    begin
      s := SeparateRight(s, ':');
      repeat
        t:=FetchEx(s, ',', '"');
        t2 := InlineDecode(t, cp);
        if t2 <> '' then begin
            if t2 = t then
                t2:=AnsiToUtf8(Trim(t2));
          FCCList.Add(t2);
        end;
      until s = '';
      continue;
    end;
    if Pos('DATE:', UpperCase(s)) = 1 then
    begin
      FDate := DecodeRfcDateTime(SeparateRight(s, ':'));
      continue;
    end;
    if Pos('X-PRIORITY:', UpperCase(s)) = 1 then begin
        try
            cpy:=StrToInt(SeparateLeft(Trim(SeparateRight(s, ':')), ' '));
            FPriority:=TmailPriority(cpy - 1);
        except
            FPriority:=mpNormal;
        end;
        prioritySet:=True;
        continue;
    end;
    if (Pos('PRIORITY:', UpperCase(s)) = 1) and (not prioritySet)then begin
        t:=SeparateRight(s, ':');
        t:=UpperCase(t);
        if t = 'URGENT' then