home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / MIMEmess.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-18  |  17KB  |  498 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 002.001.001 |
  3. |==============================================================================|
  4. | Content: MIME message object                                                 |
  5. |==============================================================================|
  6. | Copyright (c)1999-2002, Lukas Gebauer                                        |
  7. | All rights reserved.                                                         |
  8. |                                                                              |
  9. | Redistribution and use in source and binary forms, with or without           |
  10. | modification, are permitted provided that the following conditions are met:  |
  11. |                                                                              |
  12. | Redistributions of source code must retain the above copyright notice, this  |
  13. | list of conditions and the following disclaimer.                             |
  14. |                                                                              |
  15. | Redistributions in binary form must reproduce the above copyright notice,    |
  16. | this list of conditions and the following disclaimer in the documentation    |
  17. | and/or other materials provided with the distribution.                       |
  18. |                                                                              |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may      |
  20. | be used to endorse or promote products derived from this software without    |
  21. | specific prior written permission.                                           |
  22. |                                                                              |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
  33. | DAMAGE.                                                                      |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c)2000-2002.                |
  37. | All Rights Reserved.                                                         |
  38. |==============================================================================|
  39. | Contributor(s):                                                              |
  40. |==============================================================================|
  41. | History: see HISTORY.HTM From distribution package                           |
  42. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  43. |==============================================================================}
  44.  
  45. {$WEAKPACKAGEUNIT ON}
  46.  
  47. unit MIMEmess;
  48.  
  49. interface
  50.  
  51. uses
  52.   Classes, SysUtils,
  53.   MIMEpart, SynaChar, SynaUtil, MIMEinLn;
  54.  
  55. type
  56.   TMessHeader = class(TObject)
  57.   private
  58.     FFrom: string;
  59.     FToList: TStringList;
  60.     FCCList: TStringList;
  61.     FSubject: string;
  62.     FOrganization: string;
  63.     FCustomHeaders: TStringList;
  64.     FDate: TDateTime;
  65.     FXMailer: string;
  66.   public
  67.     constructor Create;
  68.     destructor Destroy; override;
  69.     procedure Clear;
  70.     procedure EncodeHeaders(const Value: TStrings);
  71.     procedure DecodeHeaders(const Value: TStrings);
  72.     function FindHeader(Value: string): string;
  73.     procedure FindHeaderList(Value: string; const HeaderList: TStrings);
  74.   published
  75.     property From: string read FFrom Write FFrom;
  76.     property ToList: TStringList read FToList;
  77.     property CCList: TStringList read FCCList;
  78.     property Subject: string read FSubject Write FSubject;
  79.     property Organization: string read FOrganization Write FOrganization;
  80.     property CustomHeaders: TStringList read FCustomHeaders;
  81.     property Date: TDateTime read FDate Write FDate;
  82.     property XMailer: string read FXMailer Write FXMailer;
  83.   end;
  84.  
  85.   TMimeMess = class(TObject)
  86.   private
  87.     FMessagePart: TMimePart;
  88.     FLines: TStringList;
  89.     FHeader: TMessHeader;
  90.   public
  91.     constructor Create;
  92.     destructor Destroy; override;
  93.     procedure Clear;
  94.     function AddPart(const PartParent: TMimePart): TMimePart;
  95.     function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
  96.     function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
  97.     function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
  98.     function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
  99.     function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
  100.     function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
  101.     function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
  102.     function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
  103.     function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
  104.     procedure EncodeMessage;
  105.     procedure DecodeMessage;
  106.   published
  107.     property MessagePart: TMimePart read FMessagePart;
  108.     property Lines: TStringList read FLines;
  109.     property Header: TMessHeader read FHeader;
  110.   end;
  111.  
  112. implementation
  113.  
  114. {==============================================================================}
  115.  
  116. constructor TMessHeader.Create;
  117. begin
  118.   inherited Create;
  119.   FToList := TStringList.Create;
  120.   FCCList := TStringList.Create;
  121.   FCustomHeaders := TStringList.Create;
  122. end;
  123.  
  124. destructor TMessHeader.Destroy;
  125. begin
  126.   FCustomHeaders.Free;
  127.   FCCList.Free;
  128.   FToList.Free;
  129.   inherited Destroy;
  130. end;
  131.  
  132. {==============================================================================}
  133.  
  134. procedure TMessHeader.Clear;
  135. begin
  136.   FFrom := '';
  137.   FToList.Clear;
  138.   FCCList.Clear;
  139.   FSubject := '';
  140.   FOrganization := '';
  141.   FCustomHeaders.Clear;
  142.   FDate := 0;
  143.   FXMailer := '';
  144. end;
  145.  
  146. procedure TMessHeader.EncodeHeaders(const Value: TStrings);
  147. var
  148.   n: Integer;
  149.   s: string;
  150. begin
  151.   if FDate = 0 then
  152.     FDate := Now;
  153.   for n := FCustomHeaders.Count - 1 downto 0 do
  154.     if FCustomHeaders[n] <> '' then
  155.       Value.Insert(0, FCustomHeaders[n]);
  156.   if FXMailer = '' then
  157.     Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
  158.   else
  159.     Value.Insert(0, 'x-mailer: ' + FXMailer);
  160.   Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
  161.   if FOrganization <> '' then
  162.     Value.Insert(0, 'Organization: ' + InlineCode(FOrganization));
  163.   s := '';
  164.   for n := 0 to FCCList.Count - 1 do
  165.     if s = '' then
  166.       s := InlineEmail(FCCList[n])
  167.     else
  168.       s := s + ' , ' + InlineEmail(FCCList[n]);
  169.   if s <> '' then
  170.     Value.Insert(0, 'CC: ' + s);
  171.   Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
  172.   if FSubject <> '' then
  173.     Value.Insert(0, 'Subject: ' + InlineCode(FSubject));
  174.   s := '';
  175.   for n := 0 to FToList.Count - 1 do
  176.     if s = '' then
  177.       s := InlineEmail(FToList[n])
  178.     else
  179.       s := s + ' , ' + InlineEmail(FToList[n]);
  180.   if s <> '' then
  181.     Value.Insert(0, 'To: ' + s);
  182.   Value.Insert(0, 'From: ' + InlineEmail(FFrom));
  183. end;
  184.  
  185. procedure TMessHeader.DecodeHeaders(const Value: TStrings);
  186. var
  187.   s, t: string;
  188.   x: Integer;
  189.   cp: TMimeChar;
  190. begin
  191.   cp := GetCurCP;
  192.   Clear;
  193.   x := 0;
  194.   while Value.Count > x do
  195.   begin
  196.     s := NormalizeHeader(Value, x);
  197.     if s = '' then
  198.       Break;
  199.     if Pos('X-MAILER:', UpperCase(s)) = 1 then
  200.     begin
  201.       FXMailer := SeparateRight(s, ':');
  202.       continue;
  203.     end;
  204.     if Pos('FROM:', UpperCase(s)) = 1 then
  205.     begin
  206.       FFrom := InlineDecode(SeparateRight(s, ':'), cp);
  207.       continue;
  208.     end;
  209.     if Pos('SUBJECT:', UpperCase(s)) = 1 then
  210.     begin
  211.       FSubject := InlineDecode(SeparateRight(s, ':'), cp);
  212.       continue;
  213.     end;
  214.     if Pos('ORGANIZATION:', UpperCase(s)) = 1 then
  215.     begin
  216.       FOrganization := InlineDecode(SeparateRight(s, ':'), cp);
  217.       continue;
  218.     end;
  219.     if Pos('TO:', UpperCase(s)) = 1 then
  220.     begin
  221.       s := SeparateRight(s, ':');
  222.       repeat
  223.         t := InlineDecode(fetch(s, ','), cp);
  224.         if t <> '' then
  225.           FToList.Add(t);
  226.       until s = '';
  227.       continue;
  228.     end;
  229.     if Pos('CC:', UpperCase(s)) = 1 then
  230.     begin
  231.       s := SeparateRight(s, ':');
  232.       repeat
  233.         t := InlineDecode(fetch(s, ','), cp);
  234.         if t <> '' then
  235.           FCCList.Add(t);
  236.       until s = '';
  237.       continue;
  238.     end;
  239.     if Pos('DATE:', UpperCase(s)) = 1 then
  240.     begin
  241.       FDate := DecodeRfcDateTime(SeparateRight(s, ':'));
  242.       continue;
  243.     end;
  244.     if Pos('MIME-VERSION:', UpperCase(s)) = 1 then
  245.       continue;
  246.     if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then
  247.       continue;
  248.     if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then
  249.       continue;
  250.     if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then
  251.       continue;
  252.     if Pos('CONTENT-ID:', UpperCase(s)) = 1 then
  253.       continue;
  254.     if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then
  255.       continue;
  256.     FCustomHeaders.Add(s);
  257.   end;
  258. end;
  259.  
  260. function TMessHeader.FindHeader(Value: string): string;
  261. var
  262.   n: integer;
  263. begin
  264.   Result := '';
  265.   for n := 0 to FCustomHeaders.Count - 1 do
  266.     if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
  267.     begin
  268.       Result := SeparateRight(FCustomHeaders[n], ':');
  269.       break;
  270.     end;
  271. end;
  272.  
  273. procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
  274. var
  275.   n: integer;
  276. begin
  277.   HeaderList.Clear;
  278.   for n := 0 to FCustomHeaders.Count - 1 do
  279.     if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
  280.     begin
  281.       HeaderList.Add(SeparateRight(FCustomHeaders[n], ':'));
  282.     end;
  283. end;
  284.  
  285. {==============================================================================}
  286.  
  287. constructor TMimeMess.Create;
  288. begin
  289.   inherited Create;
  290.   FMessagePart := TMimePart.Create;
  291.   FLines := TStringList.Create;
  292.   FHeader := TMessHeader.Create;
  293. end;
  294.  
  295. destructor TMimeMess.Destroy;
  296. begin
  297.   FMessagePart.Free;
  298.   FHeader.Free;
  299.   FLines.Free;
  300.   inherited Destroy;
  301. end;
  302.  
  303. {==============================================================================}
  304.  
  305. procedure TMimeMess.Clear;
  306. begin
  307.   FMessagePart.Clear;
  308.   FLines.Clear;
  309.   FHeader.Clear;
  310. end;
  311.  
  312. {==============================================================================}
  313.  
  314. function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
  315. begin
  316.   if PartParent = nil then
  317.     Result := FMessagePart
  318.   else
  319.     Result := PartParent.AddSubPart;
  320.   Result.Clear;
  321. end;
  322.  
  323. {==============================================================================}
  324.  
  325. function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
  326. begin
  327.   Result := AddPart(PartParent);
  328.   with Result do
  329.   begin
  330.     Primary := 'Multipart';
  331.     Secondary := MultipartType;
  332.     Description := 'Multipart message';
  333.     Boundary := GenerateBoundary;
  334.     EncodePartHeader;
  335.   end;
  336. end;
  337.  
  338. function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
  339. begin
  340.   Result := AddPart(PartParent);
  341.   with Result do
  342.   begin
  343.     Value.SaveToStream(DecodedLines);
  344.     Primary := 'text';
  345.     Secondary := 'plain';
  346.     Description := 'Message text';
  347.     Disposition := 'inline';
  348.     CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
  349.       [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
  350.       ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
  351.     EncodingCode := ME_QUOTED_PRINTABLE;
  352.     EncodePart;
  353.     EncodePartHeader;
  354.   end;
  355. end;
  356.  
  357. function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
  358. begin
  359.   Result := AddPart(PartParent);
  360.   with Result do
  361.   begin
  362.     Value.SaveToStream(DecodedLines);
  363.     Primary := 'text';
  364.     Secondary := 'html';
  365.     Description := 'HTML text';
  366.     Disposition := 'inline';
  367.     CharsetCode := UTF_8;
  368.     EncodingCode := ME_QUOTED_PRINTABLE;
  369.     EncodePart;
  370.     EncodePartHeader;
  371.   end;
  372. end;
  373.  
  374. function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
  375. var
  376.   tmp: TStrings;
  377. begin
  378.   tmp := TStringList.Create;
  379.   try
  380.     tmp.LoadFromFile(FileName);
  381.     Result := AddPartText(tmp, PartParent);
  382.   Finally
  383.     tmp.Free;
  384.   end;
  385. end;
  386.  
  387. function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
  388. var
  389.   tmp: TStrings;
  390. begin
  391.   tmp := TStringList.Create;
  392.   try
  393.     tmp.LoadFromFile(FileName);
  394.     Result := AddPartHTML(tmp, PartParent);
  395.   Finally
  396.     tmp.Free;
  397.   end;
  398. end;
  399.  
  400. function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
  401. begin
  402.   Result := AddPart(PartParent);
  403.   Result.DecodedLines.LoadFromStream(Stream);
  404.   Result.MimeTypeFromExt(FileName);
  405.   Result.Description := 'Attached file: ' + FileName;
  406.   Result.Disposition := 'attachment';
  407.   Result.FileName := FileName;
  408.   Result.EncodingCode := ME_BASE64;
  409.   Result.EncodePart;
  410.   Result.EncodePartHeader;
  411. end;
  412.  
  413. function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
  414. var
  415.   tmp: TMemoryStream;
  416. begin
  417.   tmp := TMemoryStream.Create;
  418.   try
  419.     tmp.LoadFromFile(FileName);
  420.     Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
  421.   finally
  422.     tmp.Free;
  423.   end;
  424. end;
  425.  
  426. function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
  427. begin
  428.   Result := AddPart(PartParent);
  429.   Result.DecodedLines.LoadFromStream(Stream);
  430.   Result.MimeTypeFromExt(FileName);
  431.   Result.Description := 'Included file: ' + FileName;
  432.   Result.Disposition := 'inline';
  433.   Result.ContentID := Cid;
  434.   Result.FileName := FileName;
  435.   Result.EncodingCode := ME_BASE64;
  436.   Result.EncodePart;
  437.   Result.EncodePartHeader;
  438. end;
  439.  
  440. function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
  441. var
  442.   tmp: TMemoryStream;
  443. begin
  444.   tmp := TMemoryStream.Create;
  445.   try
  446.     tmp.LoadFromFile(FileName);
  447.     Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
  448.   finally
  449.     tmp.Free;
  450.   end;
  451. end;
  452.  
  453. {==============================================================================}
  454.  
  455. procedure TMimeMess.EncodeMessage;
  456. var
  457.   l: TStringList;
  458.   x: integer;
  459. begin
  460.   //merge headers from THeaders and header field from MessagePart
  461.   l := TStringList.Create;
  462.   try
  463.     FHeader.EncodeHeaders(l);
  464.     x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
  465.     if x >= 0 then
  466.       l.add(FMessagePart.Headers[x]);
  467.     x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
  468.     if x >= 0 then
  469.       l.add(FMessagePart.Headers[x]);
  470.     x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
  471.     if x >= 0 then
  472.       l.add(FMessagePart.Headers[x]);
  473.     x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
  474.     if x >= 0 then
  475.       l.add(FMessagePart.Headers[x]);
  476.     x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
  477.     if x >= 0 then
  478.       l.add(FMessagePart.Headers[x]);
  479.     FMessagePart.Headers.Assign(l);
  480.   finally
  481.     l.Free;
  482.   end;
  483.   FMessagePart.ComposeParts;
  484.   FLines.Assign(FMessagePart.Lines);
  485. end;
  486.  
  487. {==============================================================================}
  488.  
  489. procedure TMimeMess.DecodeMessage;
  490. begin
  491.   FHeader.Clear;
  492.   FHeader.DecodeHeaders(FLines);
  493.   FMessagePart.Lines.Assign(FLines);
  494.   FMessagePart.DecomposeParts;
  495. end;
  496.  
  497. end.
  498.