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

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