source: trunk/Packages/synapse/mimepart.pas

Last change on this file was 84, checked in by chronos, 13 years ago
  • Stored packages in uncompressed files.
File size: 33.6 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 002.008.000 |
3|==============================================================================|
4| Content: MIME support procedures and functions |
5|==============================================================================|
6| Copyright (c)1999-2008, 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-2008. |
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(MIME part handling)
46Handling with MIME parts.
47
48Used RFC: RFC-2045
49}
50
51{$IFDEF FPC}
52 {$MODE DELPHI}
53{$ENDIF}
54{$H+}
55{$Q-}
56{$R-}
57
58unit mimepart;
59
60interface
61
62uses
63 SysUtils, Classes,
64 synafpc,
65 synachar, synacode, synautil, mimeinln;
66
67type
68
69 TMimePart = class;
70
71 {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for
72 easy walking through MIME subparts.}
73 THookWalkPart = procedure(const Sender: TMimePart) of object;
74
75 {:The four types of MIME parts. (textual, multipart, message or any other
76 binary data.)}
77 TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY);
78
79 {:The various types of possible part encodings.}
80 TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
81 ME_BASE64, ME_UU, ME_XX);
82
83 {:@abstract(Object for working with parts of MIME e-mail.)
84 Each TMimePart object can handle any number of nested subparts as new
85 TMimepart objects. It can handle any tree hierarchy structure of nested MIME
86 subparts itself.
87
88 Basic tasks are:
89
90 Decoding of MIME message:
91 - store message into Lines property
92 - call DecomposeParts. Now you have decomposed MIME parts in all nested levels!
93 - now you can explore all properties and subparts. (You can use WalkPart method)
94 - if you need decode part, call DecodePart.
95
96 Encoding of MIME message:
97
98 - if you need multipart message, you must create subpart by AddSubPart.
99 - set all properties of all parts.
100 - set content of part into DecodedLines stream
101 - encode this stream by EncodePart.
102 - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!)
103 - encoded MIME message is stored in Lines property.
104 }
105 TMimePart = class(TObject)
106 private
107 FPrimary: string;
108 FPrimaryCode: TMimePrimary;
109 FSecondary: string;
110 FEncoding: string;
111 FEncodingCode: TMimeEncoding;
112 FDefaultCharset: string;
113 FCharset: string;
114 FCharsetCode: TMimeChar;
115 FTargetCharset: TMimeChar;
116 FDescription: string;
117 FDisposition: string;
118 FContentID: string;
119 FBoundary: string;
120 FFileName: string;
121 FLines: TStringList;
122 FPartBody: TStringList;
123 FHeaders: TStringList;
124 FPrePart: TStringList;
125 FPostPart: TStringList;
126 FDecodedLines: TMemoryStream;
127 FSubParts: TList;
128 FOnWalkPart: THookWalkPart;
129 FMaxLineLength: integer;
130 FSubLevel: integer;
131 FMaxSubLevel: integer;
132 FAttachInside: boolean;
133 FConvertCharset: Boolean;
134 FForcedHTMLConvert: Boolean;
135 procedure SetPrimary(Value: string);
136 procedure SetEncoding(Value: string);
137 procedure SetCharset(Value: string);
138 function IsUUcode(Value: string): boolean;
139 public
140 constructor Create;
141 destructor Destroy; override;
142
143 {:Assign content of another object to this object. (Only this part,
144 not subparts!)}
145 procedure Assign(Value: TMimePart);
146
147 {:Assign content of another object to this object. (With all subparts!)}
148 procedure AssignSubParts(Value: TMimePart);
149
150 {:Clear all data values to default values. It also call @link(ClearSubparts).}
151 procedure Clear;
152
153 {:Decode Mime part from @link(Lines) to @link(DecodedLines).}
154 procedure DecodePart;
155
156 {:Parse header lines from Headers property into another properties.}
157 procedure DecodePartHeader;
158
159 {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime
160 headers.}
161 procedure EncodePart;
162
163 {:Build header lines in Headers property from another properties.}
164 procedure EncodePartHeader;
165
166 {:generate primary and secondary mime type from filename extension in value.
167 If type not recognised, it return 'Application/octet-string' type.}
168 procedure MimeTypeFromExt(Value: string);
169
170 {:Return number of decomposed subparts. (On this level! Each of this
171 subparts can hold any number of their own nested subparts!)}
172 function GetSubPartCount: integer;
173
174 {:Get nested subpart object as new TMimePart. For getting maximum possible
175 index you can use @link(GetSubPartCount) method.}
176 function GetSubPart(index: integer): TMimePart;
177
178 {:delete subpart on given index.}
179 procedure DeleteSubPart(index: integer);
180
181 {:Clear and destroy all subpart TMimePart objects.}
182 procedure ClearSubParts;
183
184 {:Add and create new subpart.}
185 function AddSubPart: TMimePart;
186
187 {:E-mail message in @link(Lines) property is parsed into this object.
188 E-mail headers are stored in @link(Headers) property and is parsed into
189 another properties automaticly. Not need call @link(DecodePartHeader)!
190 Content of message (part) is stored into @link(PartBody) property. This
191 part is in undecoded form! If you need decode it, then you must call
192 @link(DecodePart) method by your hands. Lot of another properties is filled
193 also.
194
195 Decoding of parts you must call separately due performance reasons. (Not
196 needed to decode all parts in all reasons.)
197
198 For each MIME subpart is created new TMimepart object (accessible via
199 method @link(GetSubPart)).}
200 procedure DecomposeParts;
201
202 {:This part and all subparts is composed into one MIME message stored in
203 @link(Lines) property.}
204 procedure ComposeParts;
205
206 {:By calling this method is called @link(OnWalkPart) event for each part
207 and their subparts. It is very good for calling some code for each part in
208 MIME message}
209 procedure WalkPart;
210
211 {:Return @true when is possible create next subpart. (@link(maxSublevel)
212 is still not reached)}
213 function CanSubPart: boolean;
214 published
215 {:Primary Mime type of part. (i.e. 'application') Writing to this property
216 automaticly generate value of @link(PrimaryCode).}
217 property Primary: string read FPrimary write SetPrimary;
218
219 {:String representation of used Mime encoding in part. (i.e. 'base64')
220 Writing to this property automaticly generate value of @link(EncodingCode).}
221 property Encoding: string read FEncoding write SetEncoding;
222
223 {:String representation of used Mime charset in part. (i.e. 'iso-8859-1')
224 Writing to this property automaticly generate value of @link(CharsetCode).
225 Charset is used only for text parts.}
226 property Charset: string read FCharset write SetCharset;
227
228 {:Define default charset for decoding text MIME parts without charset
229 specification. Default value is 'ISO-8859-1' by RCF documents.
230 But Microsoft Outlook use windows codings as default. This property allows
231 properly decode textual parts from some broken versions of Microsoft
232 Outlook. (this is bad software!)}
233 property DefaultCharset: string read FDefaultCharset write FDefaultCharset;
234
235 {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART,
236 MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.}
237 property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
238
239 {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT,
240 ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is
241 ME_7BIT.}
242 property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
243
244 {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.}
245 property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
246
247 {:System charset type. Default value is charset used by default in your
248 operating system.}
249 property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
250
251 {:If @true, then do internal charset translation of part content between @link(CharsetCode)
252 and @link(TargetCharset)}
253 property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset;
254
255 {:If @true, then allways do internal charset translation of HTML parts
256 by MIME even it have their own charset in META tag. Default is @false.}
257 property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert;
258
259 {:Secondary Mime type of part. (i.e. 'mixed')}
260 property Secondary: string read FSecondary Write FSecondary;
261
262 {:Description of Mime part.}
263 property Description: string read FDescription Write FDescription;
264
265 {:Value of content disposition field. (i.e. 'inline' or 'attachment')}
266 property Disposition: string read FDisposition Write FDisposition;
267
268 {:Content ID.}
269 property ContentID: string read FContentID Write FContentID;
270
271 {:Boundary delimiter of multipart Mime part. Used only in multipart part.}
272 property Boundary: string read FBoundary Write FBoundary;
273
274 {:Filename of file in binary part.}
275 property FileName: string read FFileName Write FFileName;
276
277 {:String list with lines contains mime part (It can be a full message).}
278 property Lines: TStringList read FLines;
279
280 {:Encoded form of MIME part data.}
281 property PartBody: TStringList read FPartBody;
282
283 {:All header lines of MIME part.}
284 property Headers: TStringList read FHeaders;
285
286 {:On multipart this contains part of message between first line of message
287 and first boundary.}
288 property PrePart: TStringList read FPrePart;
289
290 {:On multipart this contains part of message between last boundary and end
291 of message.}
292 property PostPart: TStringList read FPostPart;
293
294 {:Stream with decoded form of budy part.}
295 property DecodedLines: TMemoryStream read FDecodedLines;
296
297 {:Show nested level in subpart tree. Value 0 means root part. 1 means
298 subpart from this root. etc.}
299 property SubLevel: integer read FSubLevel write FSubLevel;
300
301 {:Specify maximum sublevel value for decomposing.}
302 property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
303
304 {:When is @true, then this part maybe(!) have included some uuencoded binary
305 data.}
306 property AttachInside: boolean read FAttachInside;
307
308 {:Here you can assign hook procedure for walking through all part and their
309 subparts.}
310 property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
311
312 {:Here you can specify maximum line length for encoding of MIME part.
313 If line is longer, then is splitted by standard of MIME. Correct MIME
314 mailers can de-split this line into original length.}
315 property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
316 end;
317
318const
319 MaxMimeType = 25;
320 MimeType: array[0..MaxMimeType, 0..2] of string =
321 (
322 ('AU', 'audio', 'basic'),
323 ('AVI', 'video', 'x-msvideo'),
324 ('BMP', 'image', 'BMP'),
325 ('DOC', 'application', 'MSWord'),
326 ('EPS', 'application', 'Postscript'),
327 ('GIF', 'image', 'GIF'),
328 ('JPEG', 'image', 'JPEG'),
329 ('JPG', 'image', 'JPEG'),
330 ('MID', 'audio', 'midi'),
331 ('MOV', 'video', 'quicktime'),
332 ('MPEG', 'video', 'MPEG'),
333 ('MPG', 'video', 'MPEG'),
334 ('MP2', 'audio', 'mpeg'),
335 ('MP3', 'audio', 'mpeg'),
336 ('PDF', 'application', 'PDF'),
337 ('PNG', 'image', 'PNG'),
338 ('PS', 'application', 'Postscript'),
339 ('QT', 'video', 'quicktime'),
340 ('RA', 'audio', 'x-realaudio'),
341 ('RTF', 'application', 'RTF'),
342 ('SND', 'audio', 'basic'),
343 ('TIF', 'image', 'TIFF'),
344 ('TIFF', 'image', 'TIFF'),
345 ('WAV', 'audio', 'x-wav'),
346 ('WPD', 'application', 'Wordperfect5.1'),
347 ('ZIP', 'application', 'ZIP')
348 );
349
350{:Generates a unique boundary string.}
351function GenerateBoundary: string;
352
353implementation
354
355{==============================================================================}
356
357constructor TMIMEPart.Create;
358begin
359 inherited Create;
360 FOnWalkPart := nil;
361 FLines := TStringList.Create;
362 FPartBody := TStringList.Create;
363 FHeaders := TStringList.Create;
364 FPrePart := TStringList.Create;
365 FPostPart := TStringList.Create;
366 FDecodedLines := TMemoryStream.Create;
367 FSubParts := TList.Create;
368 FTargetCharset := GetCurCP;
369 //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default
370 //system charset instead.
371 FDefaultCharset := GetIDFromCP(GetCurCP);
372 FMaxLineLength := 78;
373 FSubLevel := 0;
374 FMaxSubLevel := -1;
375 FAttachInside := false;
376 FConvertCharset := true;
377 FForcedHTMLConvert := false;
378end;
379
380destructor TMIMEPart.Destroy;
381begin
382 ClearSubParts;
383 FSubParts.Free;
384 FDecodedLines.Free;
385 FPartBody.Free;
386 FLines.Free;
387 FHeaders.Free;
388 FPrePart.Free;
389 FPostPart.Free;
390 inherited Destroy;
391end;
392
393{==============================================================================}
394
395procedure TMIMEPart.Clear;
396begin
397 FPrimary := '';
398 FEncoding := '';
399 FCharset := '';
400 FPrimaryCode := MP_TEXT;
401 FEncodingCode := ME_7BIT;
402 FCharsetCode := ISO_8859_1;
403 FTargetCharset := GetCurCP;
404 FSecondary := '';
405 FDisposition := '';
406 FContentID := '';
407 FDescription := '';
408 FBoundary := '';
409 FFileName := '';
410 FAttachInside := False;
411 FPartBody.Clear;
412 FHeaders.Clear;
413 FPrePart.Clear;
414 FPostPart.Clear;
415 FDecodedLines.Clear;
416 FConvertCharset := true;
417 FForcedHTMLConvert := false;
418 ClearSubParts;
419end;
420
421{==============================================================================}
422
423procedure TMIMEPart.Assign(Value: TMimePart);
424begin
425 Primary := Value.Primary;
426 Encoding := Value.Encoding;
427 Charset := Value.Charset;
428 DefaultCharset := Value.DefaultCharset;
429 PrimaryCode := Value.PrimaryCode;
430 EncodingCode := Value.EncodingCode;
431 CharsetCode := Value.CharsetCode;
432 TargetCharset := Value.TargetCharset;
433 Secondary := Value.Secondary;
434 Description := Value.Description;
435 Disposition := Value.Disposition;
436 ContentID := Value.ContentID;
437 Boundary := Value.Boundary;
438 FileName := Value.FileName;
439 Lines.Assign(Value.Lines);
440 PartBody.Assign(Value.PartBody);
441 Headers.Assign(Value.Headers);
442 PrePart.Assign(Value.PrePart);
443 PostPart.Assign(Value.PostPart);
444 MaxLineLength := Value.MaxLineLength;
445 FAttachInside := Value.AttachInside;
446 FConvertCharset := Value.ConvertCharset;
447end;
448
449{==============================================================================}
450
451procedure TMIMEPart.AssignSubParts(Value: TMimePart);
452var
453 n: integer;
454 p: TMimePart;
455begin
456 Assign(Value);
457 for n := 0 to Value.GetSubPartCount - 1 do
458 begin
459 p := AddSubPart;
460 p.AssignSubParts(Value.GetSubPart(n));
461 end;
462end;
463
464{==============================================================================}
465
466function TMIMEPart.GetSubPartCount: integer;
467begin
468 Result := FSubParts.Count;
469end;
470
471{==============================================================================}
472
473function TMIMEPart.GetSubPart(index: integer): TMimePart;
474begin
475 Result := nil;
476 if Index < GetSubPartCount then
477 Result := TMimePart(FSubParts[Index]);
478end;
479
480{==============================================================================}
481
482procedure TMIMEPart.DeleteSubPart(index: integer);
483begin
484 if Index < GetSubPartCount then
485 begin
486 GetSubPart(Index).Free;
487 FSubParts.Delete(Index);
488 end;
489end;
490
491{==============================================================================}
492
493procedure TMIMEPart.ClearSubParts;
494var
495 n: integer;
496begin
497 for n := 0 to GetSubPartCount - 1 do
498 TMimePart(FSubParts[n]).Free;
499 FSubParts.Clear;
500end;
501
502{==============================================================================}
503
504function TMIMEPart.AddSubPart: TMimePart;
505begin
506 Result := TMimePart.Create;
507 Result.DefaultCharset := FDefaultCharset;
508 FSubParts.Add(Result);
509 Result.SubLevel := FSubLevel + 1;
510 Result.MaxSubLevel := FMaxSubLevel;
511end;
512
513{==============================================================================}
514
515procedure TMIMEPart.DecomposeParts;
516var
517 x: integer;
518 s: string;
519 Mime: TMimePart;
520
521 procedure SkipEmpty;
522 begin
523 while FLines.Count > x do
524 begin
525 s := TrimRight(FLines[x]);
526 if s <> '' then
527 Break;
528 Inc(x);
529 end;
530 end;
531
532begin
533 x := 0;
534 Clear;
535 //extract headers
536 while FLines.Count > x do
537 begin
538 s := NormalizeHeader(FLines, x);
539 if s = '' then
540 Break;
541 FHeaders.Add(s);
542 end;
543 DecodePartHeader;
544 //extract prepart
545 if FPrimaryCode = MP_MULTIPART then
546 begin
547 while FLines.Count > x do
548 begin
549 s := FLines[x];
550 Inc(x);
551 if TrimRight(s) = '--' + FBoundary then
552 Break;
553 FPrePart.Add(s);
554 if not FAttachInside then
555 FAttachInside := IsUUcode(s);
556 end;
557 end;
558 //extract body part
559 if FPrimaryCode = MP_MULTIPART then
560 begin
561 repeat
562 if CanSubPart then
563 begin
564 Mime := AddSubPart;
565 while FLines.Count > x do
566 begin
567 s := FLines[x];
568 Inc(x);
569 if Pos('--' + FBoundary, s) = 1 then
570 Break;
571 Mime.Lines.Add(s);
572 end;
573 Mime.DecomposeParts;
574 end
575 else
576 begin
577 s := FLines[x];
578 Inc(x);
579 FPartBody.Add(s);
580 end;
581 if x >= FLines.Count then
582 break;
583 until s = '--' + FBoundary + '--';
584 end;
585 if (FPrimaryCode = MP_MESSAGE) and CanSubPart then
586 begin
587 Mime := AddSubPart;
588 SkipEmpty;
589 while FLines.Count > x do
590 begin
591 s := TrimRight(FLines[x]);
592 Inc(x);
593 Mime.Lines.Add(s);
594 end;
595 Mime.DecomposeParts;
596 end
597 else
598 begin
599 while FLines.Count > x do
600 begin
601 s := FLines[x];
602 Inc(x);
603 FPartBody.Add(s);
604 if not FAttachInside then
605 FAttachInside := IsUUcode(s);
606 end;
607 end;
608 //extract postpart
609 if FPrimaryCode = MP_MULTIPART then
610 begin
611 while FLines.Count > x do
612 begin
613 s := TrimRight(FLines[x]);
614 Inc(x);
615 FPostPart.Add(s);
616 if not FAttachInside then
617 FAttachInside := IsUUcode(s);
618 end;
619 end;
620end;
621
622{==============================================================================}
623
624procedure TMIMEPart.ComposeParts;
625var
626 n: integer;
627 mime: TMimePart;
628 s, t: string;
629 d1, d2, d3: integer;
630 x: integer;
631begin
632 FLines.Clear;
633 //add headers
634 for n := 0 to FHeaders.Count -1 do
635 begin
636 s := FHeaders[n];
637 repeat
638 if Length(s) < FMaxLineLength then
639 begin
640 t := s;
641 s := '';
642 end
643 else
644 begin
645 d1 := RPosEx('; ', s, FMaxLineLength);
646 d2 := RPosEx(' ', s, FMaxLineLength);
647 d3 := RPosEx(', ', s, FMaxLineLength);
648 if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
649 begin
650 x := Pos(' ', Copy(s, 2, Length(s) - 1));
651 if x < 1 then
652 x := Length(s);
653 end
654 else
655 if d1 > 0 then
656 x := d1
657 else
658 if d3 > 0 then
659 x := d3
660 else
661 x := d2 - 1;
662 t := Copy(s, 1, x);
663 Delete(s, 1, x);
664 end;
665 Flines.Add(t);
666 until s = '';
667 end;
668
669 Flines.Add('');
670 //add body
671 //if multipart
672 if FPrimaryCode = MP_MULTIPART then
673 begin
674 Flines.AddStrings(FPrePart);
675 for n := 0 to GetSubPartCount - 1 do
676 begin
677 Flines.Add('--' + FBoundary);
678 mime := GetSubPart(n);
679 mime.ComposeParts;
680 FLines.AddStrings(mime.Lines);
681 end;
682 Flines.Add('--' + FBoundary + '--');
683 Flines.AddStrings(FPostPart);
684 end;
685 //if message
686 if FPrimaryCode = MP_MESSAGE then
687 begin
688 if GetSubPartCount > 0 then
689 begin
690 mime := GetSubPart(0);
691 mime.ComposeParts;
692 FLines.AddStrings(mime.Lines);
693 end;
694 end
695 else
696 //if normal part
697 begin
698 FLines.AddStrings(FPartBody);
699 end;
700end;
701
702{==============================================================================}
703
704procedure TMIMEPart.DecodePart;
705var
706 n: Integer;
707 s, t, t2: string;
708 b: Boolean;
709begin
710 FDecodedLines.Clear;
711 case FEncodingCode of
712 ME_QUOTED_PRINTABLE:
713 s := DecodeQuotedPrintable(FPartBody.Text);
714 ME_BASE64:
715 s := DecodeBase64(FPartBody.Text);
716 ME_UU, ME_XX:
717 begin
718 s := '';
719 for n := 0 to FPartBody.Count - 1 do
720 if FEncodingCode = ME_UU then
721 s := s + DecodeUU(FPartBody[n])
722 else
723 s := s + DecodeXX(FPartBody[n]);
724 end;
725 else
726 s := FPartBody.Text;
727 end;
728 if FConvertCharset and (FPrimaryCode = MP_TEXT) then
729 if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
730 begin
731 b := false;
732 t2 := uppercase(s);
733 t := SeparateLeft(t2, '</HEAD>');
734 if length(t) <> length(s) then
735 begin
736 t := SeparateRight(t, '<HEAD>');
737 t := ReplaceString(t, '"', '');
738 t := ReplaceString(t, ' ', '');
739 b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
740 end;
741 //workaround for shitty M$ Outlook 11 which is placing this information
742 //outside <head> section
743 if not b then
744 begin
745 t := Copy(t2, 1, 2048);
746 t := ReplaceString(t, '"', '');
747 t := ReplaceString(t, ' ', '');
748 b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
749 end;
750 if not b then
751 s := CharsetConversion(s, FCharsetCode, FTargetCharset);
752 end
753 else
754 s := CharsetConversion(s, FCharsetCode, FTargetCharset);
755 WriteStrToStream(FDecodedLines, s);
756 FDecodedLines.Seek(0, soFromBeginning);
757end;
758
759{==============================================================================}
760
761procedure TMIMEPart.DecodePartHeader;
762var
763 n: integer;
764 s, su, fn: string;
765 st, st2: string;
766begin
767 Primary := 'text';
768 FSecondary := 'plain';
769 FDescription := '';
770 Charset := FDefaultCharset;
771 FFileName := '';
772 //was 7bit before, but this is more compatible with RFC-ignorant outlook
773 Encoding := '8BIT';
774 FDisposition := '';
775 FContentID := '';
776 fn := '';
777 for n := 0 to FHeaders.Count - 1 do
778 if FHeaders[n] <> '' then
779 begin
780 s := FHeaders[n];
781 su := UpperCase(s);
782 if Pos('CONTENT-TYPE:', su) = 1 then
783 begin
784 st := Trim(SeparateRight(su, ':'));
785 st2 := Trim(SeparateLeft(st, ';'));
786 Primary := Trim(SeparateLeft(st2, '/'));
787 FSecondary := Trim(SeparateRight(st2, '/'));
788 if (FSecondary = Primary) and (Pos('/', st2) < 1) then
789 FSecondary := '';
790 case FPrimaryCode of
791 MP_TEXT:
792 begin
793 Charset := UpperCase(GetParameter(s, 'charset'));
794 FFileName := GetParameter(s, 'name');
795 end;
796 MP_MULTIPART:
797 FBoundary := GetParameter(s, 'Boundary');
798 MP_MESSAGE:
799 begin
800 end;
801 MP_BINARY:
802 FFileName := GetParameter(s, 'name');
803 end;
804 end;
805 if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
806 Encoding := Trim(SeparateRight(su, ':'));
807 if Pos('CONTENT-DESCRIPTION:', su) = 1 then
808 FDescription := Trim(SeparateRight(s, ':'));
809 if Pos('CONTENT-DISPOSITION:', su) = 1 then
810 begin
811 FDisposition := SeparateRight(su, ':');
812 FDisposition := Trim(SeparateLeft(FDisposition, ';'));
813 fn := GetParameter(s, 'FileName');
814 end;
815 if Pos('CONTENT-ID:', su) = 1 then
816 FContentID := Trim(SeparateRight(s, ':'));
817 end;
818 if fn <> '' then
819 FFileName := fn;
820 FFileName := InlineDecode(FFileName, FTargetCharset);
821 FFileName := ExtractFileName(FFileName);
822end;
823
824{==============================================================================}
825
826procedure TMIMEPart.EncodePart;
827var
828 l: TStringList;
829 s, t: string;
830 n, x: Integer;
831 d1, d2: integer;
832begin
833 if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
834 Encoding := 'base64';
835 l := TStringList.Create;
836 FPartBody.Clear;
837 FDecodedLines.Seek(0, soFromBeginning);
838 try
839 case FPrimaryCode of
840 MP_MULTIPART, MP_MESSAGE:
841 FPartBody.LoadFromStream(FDecodedLines);
842 MP_TEXT, MP_BINARY:
843 begin
844 s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
845 if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
846 s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode);
847 if FEncodingCode = ME_BASE64 then
848 begin
849 x := 1;
850 while x <= length(s) do
851 begin
852 t := copy(s, x, 54);
853 x := x + length(t);
854 t := EncodeBase64(t);
855 FPartBody.Add(t);
856 end;
857 end
858 else
859 begin
860 if FPrimaryCode = MP_BINARY then
861 l.Add(s)
862 else
863 l.Text := s;
864 for n := 0 to l.Count - 1 do
865 begin
866 s := l[n];
867 if FEncodingCode = ME_QUOTED_PRINTABLE then
868 begin
869 s := EncodeQuotedPrintable(s);
870 repeat
871 if Length(s) < FMaxLineLength then
872 begin
873 t := s;
874 s := '';
875 end
876 else
877 begin
878 d1 := RPosEx('=', s, FMaxLineLength);
879 d2 := RPosEx(' ', s, FMaxLineLength);
880 if (d1 = 0) and (d2 = 0) then
881 x := FMaxLineLength
882 else
883 if d1 > d2 then
884 x := d1 - 1
885 else
886 x := d2 - 1;
887 if x = 0 then
888 x := FMaxLineLength;
889 t := Copy(s, 1, x);
890 Delete(s, 1, x);
891 if s <> '' then
892 t := t + '=';
893 end;
894 FPartBody.Add(t);
895 until s = '';
896 end
897 else
898 FPartBody.Add(s);
899 end;
900 if (FPrimaryCode = MP_BINARY)
901 and (FEncodingCode = ME_QUOTED_PRINTABLE) then
902 FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
903 end;
904 end;
905 end;
906 finally
907 l.Free;
908 end;
909end;
910
911{==============================================================================}
912
913procedure TMIMEPart.EncodePartHeader;
914var
915 s: string;
916begin
917 FHeaders.Clear;
918 if FSecondary = '' then
919 case FPrimaryCode of
920 MP_TEXT:
921 FSecondary := 'plain';
922 MP_MULTIPART:
923 FSecondary := 'mixed';
924 MP_MESSAGE:
925 FSecondary := 'rfc822';
926 MP_BINARY:
927 FSecondary := 'octet-stream';
928 end;
929 if FDescription <> '' then
930 FHeaders.Insert(0, 'Content-Description: ' + FDescription);
931 if FDisposition <> '' then
932 begin
933 s := '';
934 if FFileName <> '' then
935 s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
936 FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
937 end;
938 if FContentID <> '' then
939 FHeaders.Insert(0, 'Content-ID: ' + FContentID);
940
941 case FEncodingCode of
942 ME_7BIT:
943 s := '7bit';
944 ME_8BIT:
945 s := '8bit';
946 ME_QUOTED_PRINTABLE:
947 s := 'Quoted-printable';
948 ME_BASE64:
949 s := 'Base64';
950 end;
951 case FPrimaryCode of
952 MP_TEXT,
953 MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s);
954 end;
955 case FPrimaryCode of
956 MP_TEXT:
957 s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
958 MP_MULTIPART:
959 s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
960 MP_MESSAGE, MP_BINARY:
961 s := FPrimary + '/' + FSecondary;
962 end;
963 if FFileName <> '' then
964 s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
965 FHeaders.Insert(0, 'Content-type: ' + s);
966end;
967
968{==============================================================================}
969
970procedure TMIMEPart.MimeTypeFromExt(Value: string);
971var
972 s: string;
973 n: Integer;
974begin
975 Primary := '';
976 FSecondary := '';
977 s := UpperCase(ExtractFileExt(Value));
978 if s = '' then
979 s := UpperCase(Value);
980 s := SeparateRight(s, '.');
981 for n := 0 to MaxMimeType do
982 if MimeType[n, 0] = s then
983 begin
984 Primary := MimeType[n, 1];
985 FSecondary := MimeType[n, 2];
986 Break;
987 end;
988 if Primary = '' then
989 Primary := 'application';
990 if FSecondary = '' then
991 FSecondary := 'octet-stream';
992end;
993
994{==============================================================================}
995
996procedure TMIMEPart.WalkPart;
997var
998 n: integer;
999 m: TMimepart;
1000begin
1001 if assigned(OnWalkPart) then
1002 begin
1003 OnWalkPart(self);
1004 for n := 0 to GetSubPartCount - 1 do
1005 begin
1006 m := GetSubPart(n);
1007 m.OnWalkPart := OnWalkPart;
1008 m.WalkPart;
1009 end;
1010 end;
1011end;
1012
1013{==============================================================================}
1014
1015procedure TMIMEPart.SetPrimary(Value: string);
1016var
1017 s: string;
1018begin
1019 FPrimary := Value;
1020 s := UpperCase(Value);
1021 FPrimaryCode := MP_BINARY;
1022 if Pos('TEXT', s) = 1 then
1023 FPrimaryCode := MP_TEXT;
1024 if Pos('MULTIPART', s) = 1 then
1025 FPrimaryCode := MP_MULTIPART;
1026 if Pos('MESSAGE', s) = 1 then
1027 FPrimaryCode := MP_MESSAGE;
1028end;
1029
1030procedure TMIMEPart.SetEncoding(Value: string);
1031var
1032 s: string;
1033begin
1034 FEncoding := Value;
1035 s := UpperCase(Value);
1036 FEncodingCode := ME_7BIT;
1037 if Pos('8BIT', s) = 1 then
1038 FEncodingCode := ME_8BIT;
1039 if Pos('QUOTED-PRINTABLE', s) = 1 then
1040 FEncodingCode := ME_QUOTED_PRINTABLE;
1041 if Pos('BASE64', s) = 1 then
1042 FEncodingCode := ME_BASE64;
1043 if Pos('X-UU', s) = 1 then
1044 FEncodingCode := ME_UU;
1045 if Pos('X-XX', s) = 1 then
1046 FEncodingCode := ME_XX;
1047end;
1048
1049procedure TMIMEPart.SetCharset(Value: string);
1050begin
1051 if value <> '' then
1052 begin
1053 FCharset := Value;
1054 FCharsetCode := GetCPFromID(Value);
1055 end;
1056end;
1057
1058function TMIMEPart.CanSubPart: boolean;
1059begin
1060 Result := True;
1061 if FMaxSubLevel <> -1 then
1062 Result := FMaxSubLevel > FSubLevel;
1063end;
1064
1065function TMIMEPart.IsUUcode(Value: string): boolean;
1066begin
1067 Value := UpperCase(Value);
1068 Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> '');
1069end;
1070
1071{==============================================================================}
1072
1073function GenerateBoundary: string;
1074var
1075 x, y: Integer;
1076begin
1077 y := GetTick;
1078 x := y;
1079 while TickDelta(y, x) = 0 do
1080 begin
1081 Sleep(1);
1082 x := GetTick;
1083 end;
1084 Randomize;
1085 y := Random(MaxInt);
1086 Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
1087end;
1088
1089end.
Note: See TracBrowser for help on using the repository browser.