home *** CD-ROM | disk | FTP | other *** search
/ Freelog 11 / Freelog011.iso / BestOf / PhoenixMail / Source / phoenix / MailParser.pas < prev    next >
Pascal/Delphi Source File  |  1999-02-04  |  9KB  |  301 lines
  1. {*****************************************************************************
  2.  *
  3.  *  MailParser.pas - E-mail Parser (22-July-1998)
  4.  *
  5.  *  Copyright (c) 1998-99 Michael Haller
  6.  *
  7.  *  Author:     Michael Haller
  8.  *  E-mail:     michael@discountdrive.com
  9.  *  Homepage:   http://www.discountdrive.com/sunrise
  10.  *
  11.  *  This program is free software; you can redistribute it and/or
  12.  *  modify it under the terms of the GNU General Public License
  13.  *  as published by the Free Software Foundation;
  14.  *
  15.  *  This program is distributed in the hope that it will be useful,
  16.  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.  *  GNU General Public License for more details.
  19.  *
  20.  *  You should have received a copy of the GNU General Public License
  21.  *  along with this program; if not, write to the Free Software
  22.  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
  23.  *
  24.  *----------------------------------------------------------------------------
  25.  *
  26.  *  Revision history:
  27.  *
  28.  *     DATE     REV                 DESCRIPTION
  29.  *  ----------- --- ----------------------------------------------------------
  30.  *
  31.  *****************************************************************************}
  32.  
  33. unit MailParser;
  34.  
  35. interface
  36.  
  37. uses
  38.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  39.   BASE64Sup, DateSup, ParserSup;
  40.  
  41. type
  42.   TMsgType = (mtText, mtHtml, mtRich);
  43.  
  44.   TEMail = class(TObject)
  45.   private
  46.   public
  47.     ToReceiver, CC, BCC: TStringList;
  48.     Fields, FieldValues: TStringList;
  49.     Subject, Keywords, Priority, From: String;
  50.     ADate, ATime: TDateTime;
  51.     UseMime10: Boolean;
  52.     ContentType, ContentEncoding: String;
  53.     MsgType: TMsgType;
  54.     constructor Create;
  55.     destructor Destroy; override;
  56.     procedure GetMailHeader(var SL: TStringList);
  57.     procedure ParseMail(Filename: String; OnlyHeader: Boolean);
  58.     procedure CompileMsgFileOnDisk(Filename: String);
  59.   end;
  60.  
  61. implementation
  62.  
  63. uses
  64.   Main, PXStuff;
  65.  
  66. var
  67.   F, G: Text;
  68.  
  69. constructor TEMail.Create;
  70. begin
  71.   inherited Create;
  72.   ToReceiver := TStringList.Create;
  73.   CC := TStringList.Create;
  74.   BCC := TStringList.Create;
  75.   Fields := TStringList.Create;
  76.   FieldValues := TStringList.Create;
  77. end;
  78.  
  79. destructor TEMail.Destroy;
  80. begin
  81.   ToReceiver.Free;
  82.   CC.Free;
  83.   BCC.Free;
  84.   Fields.Free;
  85.   FieldValues.Free;
  86.   inherited Destroy;
  87. end;
  88.  
  89. procedure TEMail.GetMailHeader(var SL: TStringList);
  90. var
  91.   I: Integer;
  92.   S1, S2: String;
  93. begin
  94.   try
  95.     ToReceiver.Clear;
  96.     CC.Clear;
  97.     BCC.Clear;
  98.     Fields.Clear;
  99.     FieldValues.Clear;
  100.     From := '';
  101.     Priority := '';
  102.     Subject := '';
  103.     Keywords := '';
  104.     ADate := Date;
  105.     ATime := Time;
  106.     UseMIME10 := False;
  107.     ContentEncoding := '7Bit';
  108.     ContentType := 'text/plain';
  109.     MsgType := StandardMsgType;
  110.     MakeFields(SL, True);
  111.     for I := 0 to SL.Count-1 do begin
  112.       GetFieldArguments(SL.Strings[I], S1, S2);
  113.       if LowerCase(S1) = 'from' then From := SkipChar(S2, '"') else
  114.       if LowerCase(S1) = 'subject' then Subject := S2 else
  115.       if LowerCase(S1) = 'to' then CommataStringToStringList(S2, ToReceiver) else
  116.       if LowerCase(S1) = 'cc' then CommataStringToStringList(S2, CC) else
  117.       if LowerCase(S1) = 'bcc' then CommataStringToStringList(S2, BCC) else
  118.       if LowerCase(S1) = 'date' then MailTimeToDateTime(S2, ADate, ATime) else
  119.       if LowerCase(S1) = 'keywords' then Keywords := S2 else
  120.       if LowerCase(S1) = 'priority' then Priority := S2 else
  121.       if (LowerCase(S1) = 'mime-version') and (LowerCase(S2) = '1.0') then UseMime10 := True else
  122.       if LowerCase(S1) = 'content-type' then ContentType := S2 else
  123.       if LowerCase(S1) = 'content-transfer-encoding' then ContentEncoding := S2 else
  124.         begin {else}
  125.           Fields.Add(S1);
  126.           FieldValues.Add(S2);
  127.         end;
  128.     end;
  129.     // proof the value of some 'special' fields
  130.     if (LowerCase(Priority) <> 'low') and
  131.        (LowerCase(Priority) <> 'normal') and
  132.        (LowerCase(Priority) <> 'high') then Priority := 'Normal';
  133.   except end;
  134. end;
  135.  
  136. procedure TEMail.ParseMail(Filename: String; OnlyHeader: Boolean);
  137. var
  138.   S, T, S1, S2, CntType, CntEncoding: String;
  139.   SL: TStringList;
  140.   I: Integer;
  141.   BoundarayExists: Boolean;
  142. begin
  143.     try
  144.     AssignFile(F, Filename);
  145.     Reset(F);
  146.     SL := TStringList.Create;
  147.     //Load mail header
  148.     ReadLn(F, S);
  149.     while S <> '' do begin                         // until CRLF
  150.       SL.Add(S);
  151.       ReadLn(F, S);                                // fetch new line
  152.     end;
  153.     GetMailHeader(SL);
  154.     if OnlyHeader then begin
  155.       CloseFile(F);
  156.       Exit;
  157.     end;
  158.  
  159.     SL.Clear;
  160.     BoundarayExists := FAlse;
  161.     if UseMIME10 = True then begin
  162.       S := LowerCase(GetContentType('', ContentType));
  163.  
  164.     if S = 'multipart/mixed' then begin
  165.       T := '--'+GetContentType('boundary', ContentType);
  166.       T := SkipChar(T, '"');
  167.       CntType := '';
  168.       CntEncoding := '';
  169.       while not EoF(F) do begin
  170.         ReadLn(F, S);
  171.         if S = T then begin
  172.           // save previous Boundary Block
  173.           if BoundarayExists then SaveMIMEToFile(SL, CntType, CntEncoding);
  174.           // Load new boundary header
  175.           BoundarayExists := True;
  176.           SL.Clear;
  177.           ReadLn(F, S);
  178.           while S <> '' do begin
  179.             SL.Add(S);
  180.             ReadLn(F, S);
  181.           end;
  182.           MakeFields(SL, True);
  183.           for I := 0 to SL.Count-1 do begin
  184.             GetFieldArguments(SL.Strings[I], S1, S2);
  185.             if LowerCase(S1) = 'content-type' then CntType := S2;
  186.             if LowerCase(S1) = 'content-transfer-encoding' then CntEncoding := S2;
  187.           end;
  188.           SL.Clear;
  189.         end else
  190.         if S = T+'--' then begin
  191.           if (CntEncoding <> '') and (CntType <> '') then
  192.             SaveMIMEToFile(SL, CntType, CntEncoding);
  193.           // End of mail
  194.           CloseFile(F);
  195.           SL.Free;
  196.           Exit;
  197.         end else
  198.           SL.Add(S);
  199.       end;
  200.     end else begin
  201.       while not EoF(F) do begin
  202.         ReadLn(F, S);
  203.         SL.Add(S);
  204.       end;
  205.       SaveMIMEToFile(SL, ContentType, ContentEncoding);
  206.     end;
  207.  
  208.   end;
  209.  
  210.   if UseMIME10 = False then begin
  211.     MsgType := mtText;
  212.     AssignFile(G, sTempMessageFile);
  213.     Rewrite(G);
  214.     while not EoF(F) do begin
  215.       ReadLn(F, S);
  216.       WriteLn(G, S);
  217.     end;
  218.     CloseFile(G);
  219.   end;
  220.  
  221.   CloseFile(F);
  222.  
  223.   except end;
  224. end;
  225.  
  226. procedure TEMail.CompileMsgFileOnDisk(Filename: String);
  227. var
  228.   S, S1: String;
  229.   I, Found: Integer;
  230.   B: Byte;
  231.   SearchRec: TSearchRec;
  232. begin
  233.   AssignFile(F, Filename);
  234.   Rewrite(F);
  235.   // Header
  236.   S := 'From: '+SetMIMEHeaderField(From);
  237.   WriteLn(F, BreakString(S));
  238.   S := 'To: '+StringListToCommataString(ToReceiver, True);
  239.   WriteLn(F, BreakString(S));
  240.   S := StringListToCommataString(CC, True);
  241.   if S <> '' then begin S := 'CC: '+S; WriteLn(F, BreakString(S)); end;
  242.   S := StringListToCommataString(BCC, True);
  243.   if S <> '' then begin S := 'BCC: '+S; WriteLn(F, BreakString(S)); end;
  244.   DateTimeToMailTime(S, ADate, ATime);
  245.   S := 'Date: '+S;
  246.   WriteLn(F, BreakString(S));
  247.   S := Subject;
  248.   if S <> '' then begin S := 'Subject: '+SetMIMEHeaderField(S); WriteLn(F, BreakString(S)); end;
  249.   S := Keywords;
  250.   if S <> '' then begin S := 'Keywords: '+SetMIMEHeaderField(S); WriteLn(F, BreakString(S)); end;
  251.   S := Priority;
  252.   if S <> '' then begin S := 'Priority: '+SetMIMEHeaderField(S); WriteLn(F, BreakString(S)); end;
  253.   for I := 0 to Fields.Count-1 do
  254.     if Fields.Strings[I] <> '' then begin
  255.       S := Fields.Strings[I];
  256.       if LowerCase(S) <> 'x-mailer' then begin
  257.         S := S+': '+SetMIMEHeaderField(FieldValues.Strings[I]);
  258.         WriteLn(F, BreakString(S));
  259.       end;
  260.     end;
  261.   WriteLn(F, BreakString('X-mailer: '+sXMailer));
  262.   WriteLn(F, BreakString('MIME-Version: 1.0'));
  263.   WriteLn(F, BreakString('Content-type: multipart/mixed; boundary=-----Phoenix-Boundary-07081998-'));
  264.   WriteLn(F, '');
  265.   //Message text
  266.   if FileExists(sTempMessageFile) then begin
  267.     WriteLn(F, '-------Phoenix-Boundary-07081998-');
  268.     if MsgType = mtText then
  269.       WriteLn(F, 'Content-type: text/plain; charset=ISO-8859-1');
  270.     if MsgType = mtRich then
  271.       WriteLn(F, 'Content-type: text/richtext; charset=ISO-8859-1');
  272.     if MsgType = mtHtml then
  273.       WriteLn(F, 'Content-type: text/html; charset=ISO-8859-1');
  274.     WriteLn(F, 'Content-transfer-encoding: Quoted-printable');
  275.     WriteLn(F, '');
  276.     AttachFileToTextfile(F, sTempMessageFile, 0);
  277.     WriteLn(F, '');
  278.   end;
  279.   //Attachments
  280.   Found := FindFirst(sTemporaryFolder+'*.*', faReadOnly+faArchive+faHidden+faSysFile, SearchRec);
  281.   while Found = 0 do begin
  282.     if (sTemporaryFolder+SearchRec.Name <> sTempMessageFile) then begin
  283.       GetMIMEType(SearchRec.Name, S, S1, B);
  284.       WriteLn(F, '-------Phoenix-Boundary-07081998-');
  285.       WriteLn(F, 'Content-type: '+S);
  286.       WriteLn(F, 'Content-transfer-encoding: '+S1);
  287.       WriteLn(F, '');
  288.       AttachFileToTextfile(F, sTemporaryFolder+SearchRec.Name, B);
  289.       WriteLn(F, '');
  290.     end;
  291.     Found := FindNext(SearchRec);
  292.   end;
  293.   FindClose(SearchRec);
  294.   //End header
  295.   WriteLn(F, '-------Phoenix-Boundary-07081998---');
  296.   WriteLn(F, '');
  297.   CloseFile(F);
  298. end;
  299.  
  300. end.
  301.