source: trunk/Packages/synapse/source/lib/mimeinln.pas

Last change on this file was 2, checked in by chronos, 12 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 9.2 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 001.001.011 |
3|==============================================================================|
4| Content: Inline MIME support procedures and functions |
5|==============================================================================|
6| Copyright (c)1999-2006, 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-2006. |
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{:@abstract(Utilities for inline MIME)
46Support for Inline MIME encoding and decoding.
47
48Used RFC: RFC-2047, RFC-2231
49}
50
51{$IFDEF FPC}
52 {$MODE DELPHI}
53{$ENDIF}
54{$H+}
55
56{$IFDEF UNICODE}
57 {$WARN IMPLICIT_STRING_CAST OFF}
58 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
59{$ENDIF}
60
61unit mimeinln;
62
63interface
64
65uses
66 SysUtils, Classes,
67 synachar, synacode, synautil;
68
69{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
70function InlineDecode(const Value: string; CP: TMimeChar): string;
71
72{:Encodes string to MIME inline encoding. The source characterset is "CP", and
73 the target charset is "MimeP".}
74function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
75
76{:Returns @true, if "Value" contains characters needed for inline coding.}
77function NeedInline(const Value: AnsiString): boolean;
78
79{:Inline mime encoding similar to @link(InlineEncode), but you can specify
80 source charset, and the target characterset is automatically assigned.}
81function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
82
83{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
84 is automatically set to the system default charset, and the target charset is
85 automatically assigned from set of allowed encoding for MIME.}
86function InlineCode(const Value: string): string;
87
88{:Converts e-mail address to canonical mime form. You can specify source charset.}
89function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
90
91{:Converts e-mail address to canonical mime form. Source charser it system
92 default charset.}
93function InlineEmail(const Value: string): string;
94
95implementation
96
97{==============================================================================}
98
99function InlineDecode(const Value: string; CP: TMimeChar): string;
100var
101 s, su, v: string;
102 x, y, z, n: Integer;
103 ichar: TMimeChar;
104 c: Char;
105
106 function SearchEndInline(const Value: string; be: Integer): Integer;
107 var
108 n, q: Integer;
109 begin
110 q := 0;
111 Result := 0;
112 for n := be + 2 to Length(Value) - 1 do
113 if Value[n] = '?' then
114 begin
115 Inc(q);
116 if (q > 2) and (Value[n + 1] = '=') then
117 begin
118 Result := n;
119 Break;
120 end;
121 end;
122 end;
123
124begin
125 Result := '';
126 v := Value;
127 x := Pos('=?', v);
128 y := SearchEndInline(v, x);
129 //fix for broken coding with begin, but not with end.
130 if (x > 0) and (y <= 0) then
131 y := Length(Result);
132 while (y > x) and (x > 0) do
133 begin
134 s := Copy(v, 1, x - 1);
135 if Trim(s) <> '' then
136 Result := Result + s;
137 s := Copy(v, x, y - x + 2);
138 Delete(v, 1, y + 1);
139 su := Copy(s, 3, Length(s) - 4);
140 z := Pos('?', su);
141 if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
142 begin
143 ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
144 c := UpperCase(su)[z + 1];
145 su := Copy(su, z + 3, Length(su) - z - 2);
146 if c = 'B' then
147 begin
148 s := DecodeBase64(su);
149 s := CharsetConversion(s, ichar, CP);
150 end;
151 if c = 'Q' then
152 begin
153 s := '';
154 for n := 1 to Length(su) do
155 if su[n] = '_' then
156 s := s + ' '
157 else
158 s := s + su[n];
159 s := DecodeQuotedPrintable(s);
160 s := CharsetConversion(s, ichar, CP);
161 end;
162 end;
163 Result := Result + s;
164 x := Pos('=?', v);
165 y := SearchEndInline(v, x);
166 end;
167 Result := Result + v;
168end;
169
170{==============================================================================}
171
172function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
173var
174 s, s1, e: string;
175 n: Integer;
176begin
177 s := CharsetConversion(Value, CP, MimeP);
178 s := EncodeSafeQuotedPrintable(s);
179 e := GetIdFromCP(MimeP);
180 s1 := '';
181 Result := '';
182 for n := 1 to Length(s) do
183 if s[n] = ' ' then
184 begin
185// s1 := s1 + '=20';
186 s1 := s1 + '_';
187 if Length(s1) > 32 then
188 begin
189 if Result <> '' then
190 Result := Result + ' ';
191 Result := Result + '=?' + e + '?Q?' + s1 + '?=';
192 s1 := '';
193 end;
194 end
195 else
196 s1 := s1 + s[n];
197 if s1 <> '' then
198 begin
199 if Result <> '' then
200 Result := Result + ' ';
201 Result := Result + '=?' + e + '?Q?' + s1 + '?=';
202 end;
203end;
204
205{==============================================================================}
206
207function NeedInline(const Value: AnsiString): boolean;
208var
209 n: Integer;
210begin
211 Result := False;
212 for n := 1 to Length(Value) do
213 if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
214 begin
215 Result := True;
216 Break;
217 end;
218end;
219
220{==============================================================================}
221
222function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
223var
224 c: TMimeChar;
225begin
226 if NeedInline(Value) then
227 begin
228 c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
229 Result := InlineEncode(Value, FromCP, c);
230 end
231 else
232 Result := Value;
233end;
234
235{==============================================================================}
236
237function InlineCode(const Value: string): string;
238begin
239 Result := InlineCodeEx(Value, GetCurCP);
240end;
241
242{==============================================================================}
243
244function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
245var
246 sd, se: string;
247begin
248 sd := GetEmailDesc(Value);
249 se := GetEmailAddr(Value);
250 if sd = '' then
251 Result := se
252 else
253 Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
254end;
255
256{==============================================================================}
257
258function InlineEmail(const Value: string): string;
259begin
260 Result := InlineEmailEx(Value, GetCurCP);
261end;
262
263end.
Note: See TracBrowser for help on using the repository browser.