unit MailParser;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   DateSup, ParserSup;

type
  // AHRK04
  TMsgType = (mtText, mtHtml, mtRich, mtEncrypted, mtSigned);

  TEMail = class(TObject)
  private
  public
    ToReceiver, CC, BCC: TStringList;
    Fields, FieldValues: TStringList;
    Subject, Keywords,Priority,From,FileName: string;
    ADate, ATime,RDate,RTime: TDateTime;
    UseMime10,RequestReply: Boolean;
    ContentType, ContentEncoding: string;
    DispositionNotification, ReturnReceipt: string;
    MsgType: TMsgType;
    cntAttachments : integer; // AH06
    constructor Create;
    destructor Destroy; override;
    procedure GetMailHeader(var SL: TStringList);
    procedure ParseMail(AFilename: string; OnlyHeader: Boolean);
    procedure CompileMsgFileOnDisk(Filename: string);
    procedure Clear;
  end;

implementation

uses
  PXStuff;

var
  F, G: Text;
  

constructor TEMail.Create;
begin
  inherited Create;
  ToReceiver := TStringList.Create;
  CC := TStringList.Create;
  BCC := TStringList.Create;
  Fields := TStringList.Create;
  FieldValues := TStringList.Create;
end;

destructor TEMail.Destroy;
begin
  ToReceiver.Free;
  CC.Free;
  BCC.Free;
  Fields.Free;
  FieldValues.Free;
  inherited Destroy;
end;

procedure TEMail.Clear;
begin
  ToReceiver.Clear;
  CC.Clear;
  BCC.Clear;
  Fields.Clear;
  FieldValues.Clear;
  From := '';
  Priority := '';
  Subject := '';
  Keywords := '';
  ReturnReceipt := '';
  ContentType := '';     // AH06!
  ContentEncoding := ''; // AH06!
  DispositionNotification := '';
  ADate := Date;
  ATime := Time;
  cntAttachments := 0;
end;




//TODO -oMjg:fetch head information of mail
procedure TEMail.GetMailHeader(var SL: TStringList);
var
  I: Integer;
  S1, S2: string;
begin
  try
    Clear;
    UseMIME10 := False;
    ContentEncoding := '7Bit';
    ContentType := 'text/plain';
    MsgType := StandardMsgType;
    MakeFields(SL, True);
    for I := 0 to SL.Count - 1 do begin
      GetFieldArguments(SL.Strings[I], S1, S2);
      if CompareText(S1, 'from') = 0 then
        From := SkipChar(S2, '"')
      else if CompareText(S1, 'subject') = 0 then
        Subject := S2
      else if CompareText(S1, 'to') = 0 then
        HeaderAddressToStringList(S2, ToReceiver) // AHRK46
      else if CompareText(S1, 'cc') = 0 then
        HeaderAddressToStringList(S2, CC)         // AHRK46
      else if CompareText(S1, 'bcc') = 0 then
        HeaderAddressToStringList(S2, BCC)        // AHRK46
      else if CompareText(S1, sReturnReceipt) = 0 then
        ReturnReceipt := S2
      else if CompareText(S1, sDispositionNotification) = 0 then
        DispositionNotification := S2
      else if CompareText(S1, 'date') = 0 then
        MailTimeToDateTime(S2, ADate, ATime)
      else if CompareText(S1, 'Received')=0 then
        begin
         s2:=copy(s2,pos(';',s2)+1,length(s2)-pos(';',s2));
         MailTimeToDateTime(S2, RDate, RTime);
        end
      else if CompareText(S1, 'keywords') = 0 then
        Keywords := S2
      else if CompareText(S1, 'X-MSMail-Priority') = 0 then
        Priority := S2
//      else if CompareText(S1, 'report-type=disposition-notification') >= 0 then
//        isReceipt:=true
      else if (CompareText(S1, 'mime-version') = 0) and (CompareText(S2, '1.0')
        = 0) then
        UseMime10 := True
      else if CompareText(S1, 'content-type') = 0 then
        ContentType := S2
      else if CompareText(S1, 'content-transfer-encoding') = 0 then
        ContentEncoding := S2
      else begin {else}
        Fields.Add(S1);
        FieldValues.Add(S2);
      end;
    end;
    // proof the value of some 'special' fields
    if (CompareText(Priority, 'low') <> 0) and
      (CompareText(Priority, 'normal') <> 0) and
      (CompareText(Priority, 'high') <> 0) then
      Priority := 'Normal';
  except
  end;
end;



procedure TEMail.ParseMail(AFilename: string; OnlyHeader: Boolean);
var
  S, T, S1, S2, CntType, CntEncoding: string;
  SL: TStringList;
  I: Integer;
  BoundsArrayExists: Boolean; //RR02e: just renamed, nothing else
  BoundsStack: TStringList; //AHRF
  iCount:integer;

  function GetlastBound: string;
  begin
    if BoundsStack.Count > 0 then
    begin
      Result := BoundsStack.Strings[BoundsStack.Count - 1];
    end
    else
      Result := '[Wood is cool!]'; //RR02e: just renamed, but I'll keep it!
  end;

  procedure PopLastBound;
  begin
    if BoundsStack.Count > 0 then
    begin
      BoundsStack.Delete(BoundsStack.Count - 1);
    end;
  end;

begin
  iCount:=0;
  FileName := AFilename;
  if not FileExists(FileName) then exit;
  AssignFile(F, AFilename);
  try
//    CloseFile(F);
    Reset(F);
    SL := TStringList.Create;
    try
      //Load mail header
      ReadLn(F, S);
      while S <> '' do begin // until CRLF
        SL.Add(S);
        ReadLn(F, S); // fetch new line
      end;
      GetMailHeader(SL);
      if OnlyHeader then
      begin
        exit;
      end;

      BoundsStack := TStringList.Create;
      try
        SL.Clear;
        HaveAttach := False;
        if UseMIME10 then begin

          S := LowerCase(GetContentType('', ContentType));
          if CompareStr(Copy(S, 1, 10), 'multipart/') = 0 then begin
            T := '--' + GetContentType('boundary', ContentType);
            T := SkipChar(T, '"');
            CntType := '';
            CntEncoding := '';
            BoundsStack.Add(T); //AHRF Add boundary to stack...
            while not EoF(F) do begin
              ReadLn(F, S);
              // Compare line with last boundary on stack...
              if CompareText(S, GetLastBound) = 0 then begin
                if BoundsArrayExists then
                begin
                  // save previous Boundary Block
                  SaveMIMEToFile(SL, CntType, CntEncoding);
                  iCount:=iCount+1;
                  cntAttachMents := cntAttachments + Ord((Pos('TEXT/PLAIN', UpperCase(cntType)) = 0)); //AH06

                end;
                BoundsArrayExists := True;
                // Load new boundary header

                SL.Clear;
                ReadLn(F, S);
                while S <> '' do begin
                  SL.Add(S);
                  ReadLn(F, S);
                end;
                MakeFields(SL, True);
                for I := 0 to SL.Count - 1 do begin
                  GetFieldArguments(SL.Strings[I], S1, S2);
                  if CompareText(S1, 'content-type') = 0 then
                    CntType := S2;
                  if CompareText(S1, 'content-transfer-encoding') = 0 then
                    CntEncoding := S2;
                end;
                // AHRF Check if current boundary has embedded boundaries
                // if so, add to stack and reset variables (CntType and
                // CntEncoding...
                if pos('multipart', Lowercase(CntType)) > 0 then
                begin
                  T := '--' + GetContentType('boundary', CntType);
                  T := SkipChar(T, '"');
                  CntType := '';
                  CntEncoding := '';
                  HaveAttach := false;
                  BoundsStack.Add(T);
                end;
                //AHRF
                SL.Clear;
              end
              else if CompareText(S, GetLastBound + '--') = 0 then begin
                // Check if this is the end boundary, and if so,
                // reset values, delete the last item on stack
                // AH16 Force writing... (additional bugfix, see Eudora/Plain/Styled
                // e-mails...
                if (CntEncoding <> '') or (CntType <> '') then
                begin
                  SaveMIMEToFile(SL, CntType, CntEncoding);
                  iCount:=iCount+1;
                  cntAttachMents := cntAttachments + Ord((Pos('TEXT/PLAIN', UpperCase(cntType)) = 0)); //AH06
                  // Reset...
                  CntType := '';
                  CntEncoding := '';
                  BoundsArrayExists := false;
                  popLastBound;
                  SL.Clear;
                end;
              end
              else
                SL.Add(S);
            end;
          end
          else begin
            while not EoF(F) do begin
              ReadLn(F, S);
              SL.Add(S);
            end;
            SaveMIMEToFile(SL, ContentType, ContentEncoding);
          end;
        end;

        if not UseMIME10 then begin
          MsgType := mtText;
          AssignFile(G, sTempMessageFile);
          Rewrite(G);
          while not EoF(F) do begin
            ReadLn(F, S);
            WriteLn(G, S);
          end;
          CloseFile(G);
        end;

        // DB17 CloseFile(F);

      // DB17 do not hide all exceptions
      {  except
      end;}
      finally // DB17
        BoundsStack.Free; //AHRF
      end;
    finally // DB17 see also exit calls in this procedure
      SL.Free; //AHRF
    end;
  finally // DB17 see also exit calls in this procedure
    CloseFile(F);
  end;
   if iCount>1 then HaveAttach:=true;
end;





//TODO -oMjg:write config information to message for transition
procedure TEMail.CompileMsgFileOnDisk(Filename: string);
var
  S, S1, Bound: string;
  I, Found: Integer;
  B: Byte;
  SearchRec: TSearchRec;
  PlainText : Boolean;
begin
  if UseHtml=true then
     MsgType:=mtHtml;
  AssignFile(F, Filename);
    Rewrite(F);
  // Header
 // S := 'From: ' + SetMIMEHeaderField(From);
  i:=pos('<',from);
  s:='From: '+'"'+trim(copy(from,1,i-1))+'"';
  s:=trim(s)+' '+copy(from,i,length(from));


 // WriteLn(F, BreakString(S, 78));
  WriteLn(F, s);
  S := 'To: ' + StringListToCommataString(ToReceiver, True);
  WriteLn(F, BreakString(S, 78));
  S := StringListToCommataString(CC, True);
  if Length(S) > 0 then begin
    S := 'CC: ' + S;
    WriteLn(F, BreakString(S, 78));
  end;
  S := StringListToCommataString(BCC, True);
  if Length(S) > 0 then begin
    S := 'BCC: ' + S;
    WriteLn(F, BreakString(S, 78));
  end;
  S := ReturnReceipt;
  if Length(S) > 0 then begin
    S := sReturnReceipt + ': ' + SetMIMEHeaderField(S);
    WriteLn(F, BreakString(S, 78));
  end;
  DateTimeToMailTime(S, ADate, ATime);
  S := 'Date: ' + S;
  WriteLn(F, BreakString(S, 78));
{  S := DispositionNotification;
  if Length(S) > 0 then begin
    S := sDispositionNotification + ': ' + SetMIMEHeaderField(S);
    WriteLn(F, BreakString(S, 78));
  end;}
  S := Subject;
  if Length(S) > 0 then begin
    S := 'Subject: ' + SetMIMEHeaderField(S);
    WriteLn(F, BreakString(S, 78));
  end;
  S := Keywords;
  if Length(S) > 0 then begin
    S := 'Keywords: ' + SetMIMEHeaderField(S);
    WriteLn(F, BreakString(S, 78));
  end;

  S := Priority;

  WriteLn(F, 'X-MSMail-Priority: '+S);
  if Length(S) > 0 then begin
    S := 'Priority: ' + SetMIMEHeaderField(S);
    WriteLn(F, BreakString(S, 78));
  end;
  for I := 0 to Fields.Count - 1 do
    if Fields.Strings[I] <> '' then
    begin
      S := Fields.Strings[I];
      if CompareText(S, 'x-mailer') <> 0 then begin
        S := S + ': ' + SetMIMEHeaderField(FieldValues.Strings[I]);
        WriteLn(F, BreakString(S, 78));
      end;

    end;

   //if it's return receipt not to write receipt flat
   if  (RequestReply or bNeedReceipt) and (not isReceipt) then
   begin
     i:=pos('<',from);
     s:='"'+trim(copy(from,1,i-1))+'"';
     s:=trim(s)+' '+copy(from,i,length(from));
     WriteLn(F, 'Disposition-Notification-To: '+s);
   end;


  PlainText := (Pos('text/plain', ContentType) > 0);

//  WriteLn(F, 'MIME-Version: 1.0'); X-MSMail-Priority
  WriteLn(F, BreakString('X-mailer: ' + sXMailer + ' (' + IntToStr(Win32MajorVersion) + '.'
                    + IntToStr(Win32MinorVersion) + '/' + InttoStr(Win32BuildNumber) + ')', 78));
  WriteLn(F, 'MIME-Version: 1.0');
  // AH06
  if PlainText then
  begin
    // Hard set... Please change after...
    WriteLn(F, 'Content-type: text/plain; charset="GB2312"');
    WriteLN(F, 'Content-transfer-encoding: quoted-printable');
  end
  else
  begin
    Bound := GenerateBoundary;
    WriteLn(F, breakstring('Content-type: multipart/alternative; boundary=' + Bound, 78));
  end;
  if isReceipt then
  begin
    WriteLn(F, 'report-type=disposition-notification');
  end;
  WriteLn(F, '');


  //Message text
  if FileExists(sTempMessageFile) then
  begin
    if PlainText then
    begin
       AttachFileToTextFile(F, sTempMessageFile, 0);
       WriteLn(F, '');
    end
    else
    begin
      WriteLn(F, '--' + Bound);
      if MsgType = mtText then
        WriteLn(F, 'Content-type: text/plain; charset=GB2312');
      if MsgType = mtRich then
        WriteLn(F, 'Content-type: text/richtext; charset=GB2312');
      if MsgType = mtHtml then
        WriteLn(F, 'Content-type: text/html; charset=GB2312');
      WriteLn(F, 'Content-transfer-encoding: Quoted-printable');
      WriteLn(F, '');
      AttachFileToTextfile(F, sTempMessageFile, 0);
      WriteLn(F, '');
    end;
  end;
  //Attachments
  cntAttachments := 0;
  Found := FindFirst(sTemporaryFolder + '*.*', faReadOnly + faArchive + faHidden
    + faSysFile, SearchRec);
  while Found = 0 do begin
    if (sTemporaryFolder + SearchRec.Name <> sTempMessageFile) then begin
      GetMIMEType(SearchRec.Name, S, S1, B);
      WriteLn(F, '--' + Bound);
      WriteLn(F, 'Content-type: ' + S);
      WriteLn(F, 'Content-transfer-encoding: ' + S1);
      WriteLn(F, '');
      AttachFileToTextfile(F, sTemporaryFolder + SearchRec.Name, B);
      WriteLn(F, '');
      inc(cntAttachments);
    end;
    Found := FindNext(SearchRec);
  end;
  FindClose(SearchRec);
  //End header
  if PlainText  then    //AH06
  begin
    WriteLN(F, '');
  end
  else
  begin
    WriteLn(F, '--' + Bound + '--');
    WriteLn(F, '');
  end;
  CloseFile(F);
end;

end.
