home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / MIMEinLn.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-07  |  7KB  |  193 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 001.000.003 |
  3. |==============================================================================|
  4. | Content: Inline MIME support procedures and functions                        |
  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,2001.                |
  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 MIMEinLn;
  48.  
  49. interface
  50.  
  51. uses
  52.   SysUtils, Classes,
  53.   SynaChar, SynaCode, SynaUtil;
  54.  
  55. function InlineDecode(const Value: string; CP: TMimeChar): string;
  56. function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
  57. function NeedInline(const Value: string): boolean;
  58. function InlineCode(const Value: string): string;
  59. function InlineEmail(const Value: string): string;
  60.  
  61. implementation
  62.  
  63. {==============================================================================}
  64.  
  65. function InlineDecode(const Value: string; CP: TMimeChar): string;
  66. var
  67.   s, su: string;
  68.   x, y, z, n: Integer;
  69.   ichar: TMimeChar;
  70.   c: Char;
  71.  
  72.   function SearchEndInline(const Value: string; be: Integer): Integer;
  73.   var
  74.     n, q: Integer;
  75.   begin
  76.     q := 0;
  77.     Result := 0;
  78.     for n := be + 2 to Length(Value) - 1 do
  79.       if Value[n] = '?' then
  80.       begin
  81.         Inc(q);
  82.         if (q > 2) and (Value[n + 1] = '=') then
  83.         begin
  84.           Result := n;
  85.           Break;
  86.         end;
  87.       end;
  88.   end;
  89.  
  90. begin
  91.   Result := Value;
  92.   x := Pos('=?', Result);
  93.   y := SearchEndInline(Result, x);
  94.   while (y > x) and (x > 0) do  //fix by Marcus Moennig (minibbjd@gmx.de)
  95.   begin
  96.     s := Copy(Result, x, y - x + 2);
  97.     su := Copy(s, 3, Length(s) - 4);
  98.     ichar := GetCPFromID(su);
  99.     z := Pos('?', su);
  100.     if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
  101.     begin
  102.       c := UpperCase(su)[z + 1];
  103.       su := Copy(su, z + 3, Length(su) - z - 2);
  104.       if c = 'B' then
  105.       begin
  106.         s := DecodeBase64(su);
  107.         s := CharsetConversion(s, ichar, CP);
  108.       end;
  109.       if c = 'Q' then
  110.       begin
  111.         s := '';
  112.         for n := 1 to Length(su) do
  113.           if su[n] = '_' then
  114.             s := s + ' '
  115.           else
  116.             s := s + su[n];
  117.         s := DecodeQuotedPrintable(s);
  118.         s := CharsetConversion(s, ichar, CP);
  119.       end;
  120.     end;
  121.     Result := Copy(Result, 1, x - 1) + s +
  122.       Copy(Result, y + 2, Length(Result) - y - 1);
  123.     x := Pos('=?', Result);
  124.     y := SearchEndInline(Result, x);
  125.   end;
  126. end;
  127.  
  128. {==============================================================================}
  129.  
  130. function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
  131. var
  132.   s, s1: string;
  133.   n: Integer;
  134. begin
  135.   s := CharsetConversion(Value, CP, MimeP);
  136.   s := EncodeQuotedPrintable(s);
  137.   s1 := '';
  138.   for n := 1 to Length(s) do
  139.     if s[n] = ' ' then
  140.       s1 := s1 + '=20'
  141.     else
  142.       s1 := s1 + s[n];
  143.   Result := '=?' + GetIdFromCP(MimeP) + '?Q?' + s1 + '?=';
  144. end;
  145.  
  146. {==============================================================================}
  147.  
  148. function NeedInline(const Value: string): boolean;
  149. var
  150.   n: Integer;
  151. begin
  152.   Result := False;
  153.   for n := 1 to Length(Value) do
  154.     if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then
  155.     begin
  156.       Result := True;
  157.       Break;
  158.     end;
  159. end;
  160.  
  161. {==============================================================================}
  162.  
  163. function InlineCode(const Value: string): string;
  164. var
  165.   c: TMimeChar;
  166. begin
  167.   if NeedInline(Value) then
  168.   begin
  169.     c := IdealCharsetCoding(Value, GetCurCP,
  170.       [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
  171.       ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
  172.     Result := InlineEncode(Value, GetCurCP, c);
  173.   end
  174.   else
  175.     Result := Value;
  176. end;
  177.  
  178. {==============================================================================}
  179.  
  180. function InlineEmail(const Value: string): string;
  181. var
  182.   sd, se: string;
  183. begin
  184.   sd := GetEmailDesc(Value);
  185.   se := GetEmailAddr(Value);
  186.   if sd = '' then
  187.     Result := se
  188.   else
  189.     Result := '"' + InlineCode(sd) + '"<' + se + '>';
  190. end;
  191.  
  192. end.
  193.