{==============================================================================|
| Project : Ararat Synapse | 002.009.002 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2021 |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2021. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME part handling)
Handling with MIME parts.
Used RFC: RFC-2045
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$Q-}
{$R-}
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimepart;
interface
uses
SysUtils, Classes,
synafpc,
synachar, synacode, synautil, mimeinln;
type
TMimePart = class;
{:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for
easy walking through MIME subparts.}
THookWalkPart = procedure(const Sender: TMimePart) of object;
{:The four types of MIME parts. (textual, multipart, message or any other
binary data.)}
TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY);
{:The various types of possible part encodings.}
TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
ME_BASE64, ME_UU, ME_XX);
{:@abstract(Object for working with parts of MIME e-mail.)
Each TMimePart object can handle any number of nested subparts as new
TMimepart objects. It can handle any tree hierarchy structure of nested MIME
subparts itself.
Basic tasks are:
Decoding of MIME message:
- store message into Lines property
- call DecomposeParts. Now you have decomposed MIME parts in all nested levels!
- now you can explore all properties and subparts. (You can use WalkPart method)
- if you need decode part, call DecodePart.
Encoding of MIME message:
- if you need multipart message, you must create subpart by AddSubPart.
- set all properties of all parts.
- set content of part into DecodedLines stream
- encode this stream by EncodePart.
- 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!)
- encoded MIME message is stored in Lines property.
}
TMimePart = class(TObject)
private
FPrimary: string;
FPrimaryCode: TMimePrimary;
FSecondary: string;
FEncoding: string;
FEncodingCode: TMimeEncoding;
FDefaultCharset: string;
FCharset: string;
FCharsetCode: TMimeChar;
FTargetCharset: TMimeChar;
FDescription: string;
FDisposition: string;
FContentID: string;
FBoundary: string;
FFileName: string;
FLines: TStringList;
FPartBody: TStringList;
FHeaders: TStringList;
FPrePart: TStringList;
FPostPart: TStringList;
FDecodedLines: TMemoryStream;
FSubParts: TList;
FOnWalkPart: THookWalkPart;
FMaxLineLength: integer;
FSubLevel: integer;
FMaxSubLevel: integer;
FAttachInside: boolean;
FConvertCharset: Boolean;
FForcedHTMLConvert: Boolean;
FBinaryDecomposer: boolean;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
function IsUUcode(Value: string): boolean;
public
constructor Create;
destructor Destroy; override;
{:Assign content of another object to this object. (Only this part,
not subparts!)}
procedure Assign(Value: TMimePart);
{:Assign content of another object to this object. (With all subparts!)}
procedure AssignSubParts(Value: TMimePart);
{:Clear all data values to default values. It also call @link(ClearSubparts).}
procedure Clear;
{:Decode Mime part from @link(Lines) to @link(DecodedLines).}
procedure DecodePart;
{:Parse header lines from Headers property into another properties.}
procedure DecodePartHeader;
{:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime
headers.}
procedure EncodePart;
{:Build header lines in Headers property from another properties.}
procedure EncodePartHeader;
{:generate primary and secondary mime type from filename extension in value.
If type not recognised, it return 'Application/octet-string' type.}
procedure MimeTypeFromExt(Value: string);
{:Return number of decomposed subparts. (On this level! Each of this
subparts can hold any number of their own nested subparts!)}
function GetSubPartCount: integer;
{:Get nested subpart object as new TMimePart. For getting maximum possible
index you can use @link(GetSubPartCount) method.}
function GetSubPart(index: integer): TMimePart;
{:delete subpart on given index.}
procedure DeleteSubPart(index: integer);
{:Clear and destroy all subpart TMimePart objects.}
procedure ClearSubParts;
{:Add and create new subpart.}
function AddSubPart: TMimePart;
{:E-mail message in @link(Lines) property is parsed into this object.
E-mail headers are stored in @link(Headers) property and is parsed into
another properties automaticly. Not need call @link(DecodePartHeader)!
Content of message (part) is stored into @link(PartBody) property. This
part is in undecoded form! If you need decode it, then you must call
@link(DecodePart) method by your hands. Lot of another properties is filled
also.
Decoding of parts you must call separately due performance reasons. (Not
needed to decode all parts in all reasons.)
For each MIME subpart is created new TMimepart object (accessible via
method @link(GetSubPart)).}
procedure DecomposeParts;
{pf}
{: HTTP message is received by @link(THTTPSend) component in two parts:
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
@link(THTTPSend.Document).
On the top of it, HTTP connections are always 8-bit, hence data are
transferred in native format i.e. no transfer encoding is applied.
This method operates the similiar way and produces the same
result as @link(DecomposeParts).
}
procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar);
{/pf}
{:This part and all subparts is composed into one MIME message stored in
@link(Lines) property.}
procedure ComposeParts;
{:By calling this method is called @link(OnWalkPart) event for each part
and their subparts. It is very good for calling some code for each part in
MIME message}
procedure WalkPart;
{:Return @true when is possible create next subpart. (@link(maxSublevel)
is still not reached)}
function CanSubPart: boolean;
published
{:Primary Mime type of part. (i.e. 'application') Writing to this property
automaticly generate value of @link(PrimaryCode).}
property Primary: string read FPrimary write SetPrimary;
{:String representation of used Mime encoding in part. (i.e. 'base64')
Writing to this property automaticly generate value of @link(EncodingCode).}
property Encoding: string read FEncoding write SetEncoding;
{:String representation of used Mime charset in part. (i.e. 'iso-8859-1')
Writing to this property automaticly generate value of @link(CharsetCode).
Charset is used only for text parts.}
property Charset: string read FCharset write SetCharset;
{:Define default charset for decoding text MIME parts without charset
specification. Default value is 'ISO-8859-1' by RCF documents.
But Microsoft Outlook use windows codings as default. This property allows
properly decode textual parts from some broken versions of Microsoft
Outlook. (this is bad software!)}
property DefaultCharset: string read FDefaultCharset write FDefaultCharset;
{:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART,
MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.}
property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
{:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT,
ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is
ME_7BIT.}
property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
{:Decoded charset type. Possible values are defined in @link(SynaChar) unit.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
{:System charset type. Default value is charset used by default in your
operating system.}
property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
{:If @true, then do internal charset translation of part content between @link(CharsetCode)
and @link(TargetCharset)}
property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset;
{:If @true, then allways do internal charset translation of HTML parts
by MIME even it have their own charset in META tag. Default is @false.}
property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert;
{:Secondary Mime type of part. (i.e. 'mixed')}
property Secondary: string read FSecondary Write FSecondary;
{:Description of Mime part.}
property Description: string read FDescription Write FDescription;
{:Value of content disposition field. (i.e. 'inline' or 'attachment')}
property Disposition: string read FDisposition Write FDisposition;
{:Content ID.}
property ContentID: string read FContentID Write FContentID;
{:Boundary delimiter of multipart Mime part. Used only in multipart part.}
property Boundary: string read FBoundary Write FBoundary;
{:Filename of file in binary part.}
property FileName: string read FFileName Write FFileName;
{:String list with lines contains mime part (It can be a full message).}
property Lines: TStringList read FLines;
{:Encoded form of MIME part data.}
property PartBody: TStringList read FPartBody;
{:All header lines of MIME part.}
property Headers: TStringList read FHeaders;
{:On multipart this contains part of message between first line of message
and first boundary.}
property PrePart: TStringList read FPrePart;
{:On multipart this contains part of message between last boundary and end
of message.}
property PostPart: TStringList read FPostPart;
{:Stream with decoded form of budy part.}
property DecodedLines: TMemoryStream read FDecodedLines;
{:Show nested level in subpart tree. Value 0 means root part. 1 means
subpart from this root. etc.}
property SubLevel: integer read FSubLevel write FSubLevel;
{:Specify maximum sublevel value for decomposing.}
property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
{:When is @true, then this part maybe(!) have included some uuencoded binary
data.}
property AttachInside: boolean read FAttachInside;
{:Here you can assign hook procedure for walking through all part and their
subparts.}
property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
{:Here you can specify maximum line length for encoding of MIME part.
If line is longer, then is splitted by standard of MIME. Correct MIME
mailers can de-split this line into original length.}
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end;
const
MaxMimeType = 25;
MimeType: array[0..MaxMimeType, 0..2] of string =
(
('AU', 'audio', 'basic'),
('AVI', 'video', 'x-msvideo'),
('BMP', 'image', 'BMP'),
('DOC', 'application', 'MSWord'),
('EPS', 'application', 'Postscript'),
('GIF', 'image', 'GIF'),
('JPEG', 'image', 'JPEG'),
('JPG', 'image', 'JPEG'),
('MID', 'audio', 'midi'),
('MOV', 'video', 'quicktime'),
('MPEG', 'video', 'MPEG'),
('MPG', 'video', 'MPEG'),
('MP2', 'audio', 'mpeg'),
('MP3', 'audio', 'mpeg'),
('PDF', 'application', 'PDF'),
('PNG', 'image', 'PNG'),
('PS', 'application', 'Postscript'),
('QT', 'video', 'quicktime'),
('RA', 'audio', 'x-realaudio'),
('RTF', 'application', 'RTF'),
('SND', 'audio', 'basic'),
('TIF', 'image', 'TIFF'),
('TIFF', 'image', 'TIFF'),
('WAV', 'audio', 'x-wav'),
('WPD', 'application', 'Wordperfect5.1'),
('ZIP', 'application', 'ZIP')
);
{:Generates a unique boundary string.}
function GenerateBoundary: string;
{:Generates a stringlist that does not write a BOM character.}
Function CreateStringList : TStringList;
implementation
{==============================================================================}
constructor TMIMEPart.Create;
begin
inherited Create;
FOnWalkPart := nil;
FLines := CreateStringList;
FPartBody := CreateStringList;
FHeaders := CreateStringList;
FPrePart := CreateStringList;
FPostPart := CreateStringList;
FDecodedLines := TMemoryStream.Create;
FSubParts := TList.Create;
FTargetCharset := GetCurCP;
//was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default
//system charset instead.
FDefaultCharset := GetIDFromCP(GetCurCP);
FMaxLineLength := 78;
FSubLevel := 0;
FMaxSubLevel := -1;
FAttachInside := false;
FConvertCharset := true;
FForcedHTMLConvert := false;
end;
destructor TMIMEPart.Destroy;
begin
ClearSubParts;
FSubParts.Free;
FDecodedLines.Free;
FPartBody.Free;
FLines.Free;
FHeaders.Free;
FPrePart.Free;
FPostPart.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMIMEPart.Clear;
begin
FPrimary := '';
FEncoding := '';
FCharset := '';
FPrimaryCode := MP_TEXT;
FEncodingCode := ME_7BIT;
FCharsetCode := ISO_8859_1;
FTargetCharset := GetCurCP;
FSecondary := '';
FDisposition := '';
FContentID := '';
FDescription := '';
FBoundary := '';
FFileName := '';
FAttachInside := False;
FPartBody.Clear;
FHeaders.Clear;
FPrePart.Clear;
FPostPart.Clear;
FDecodedLines.Clear;
FConvertCharset := true;
FForcedHTMLConvert := false;
ClearSubParts;
end;
{==============================================================================}
procedure TMIMEPart.Assign(Value: TMimePart);
begin
Primary := Value.Primary;
Encoding := Value.Encoding;
Charset := Value.Charset;
DefaultCharset := Value.DefaultCharset;
PrimaryCode := Value.PrimaryCode;
EncodingCode := Value.EncodingCode;
CharsetCode := Value.CharsetCode;
TargetCharset := Value.TargetCharset;
Secondary := Value.Secondary;
Description := Value.Description;
Disposition := Value.Disposition;
ContentID := Value.ContentID;
Boundary := Value.Boundary;
FileName := Value.FileName;
Lines.Assign(Value.Lines);
PartBody.Assign(Value.PartBody);
Headers.Assign(Value.Headers);
PrePart.Assign(Value.PrePart);
PostPart.Assign(Value.PostPart);
MaxLineLength := Value.MaxLineLength;
FAttachInside := Value.AttachInside;
FConvertCharset := Value.ConvertCharset;
end;
{==============================================================================}
procedure TMIMEPart.AssignSubParts(Value: TMimePart);
var
n: integer;
p: TMimePart;
begin
Assign(Value);
for n := 0 to Value.GetSubPartCount - 1 do
begin
p := AddSubPart;
p.AssignSubParts(Value.GetSubPart(n));
end;
end;
{==============================================================================}
function TMIMEPart.GetSubPartCount: integer;
begin
Result := FSubParts.Count;
end;
{==============================================================================}
function TMIMEPart.GetSubPart(index: integer): TMimePart;
begin
Result := nil;
if Index < GetSubPartCount then
Result := TMimePart(FSubParts[Index]);
end;
{==============================================================================}
procedure TMIMEPart.DeleteSubPart(index: integer);
begin
if Index < GetSubPartCount then
begin
GetSubPart(Index).Free;
FSubParts.Delete(Index);
end;
end;
{==============================================================================}
procedure TMIMEPart.ClearSubParts;
var
n: integer;
begin
for n := 0 to GetSubPartCount - 1 do
TMimePart(FSubParts[n]).Free;
FSubParts.Clear;
end;
{==============================================================================}
function TMIMEPart.AddSubPart: TMimePart;
begin
Result := TMimePart.Create;
Result.DefaultCharset := FDefaultCharset;
FSubParts.Add(Result);
Result.SubLevel := FSubLevel + 1;
Result.MaxSubLevel := FMaxSubLevel;
end;
{==============================================================================}
procedure TMIMEPart.DecomposeParts;
var
x: integer;
s: string;
Mime: TMimePart;
procedure SkipEmpty;
begin
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
if s <> '' then
Break;
Inc(x);
end;
end;
begin
FBinaryDecomposer := false;
x := 0;
Clear;
//extract headers
while FLines.Count > x do
begin
s := NormalizeHeader(FLines, x);
if s = '' then
Break;
FHeaders.Add(s);
end;
DecodePartHeader;
//extract prepart
if FPrimaryCode = MP_MULTIPART then
begin
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
if TrimRight(s) = '--' + FBoundary then
Break;
FPrePart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
//extract body part
if FPrimaryCode = MP_MULTIPART then
begin
repeat
if CanSubPart then
begin
Mime := AddSubPart;
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
Mime.Lines.Add(s);
end;
Mime.DecomposeParts;
end
else
begin
s := FLines[x];
Inc(x);
FPartBody.Add(s);
end;
if x >= FLines.Count then
break;
until s = '--' + FBoundary + '--';
end;
if (FPrimaryCode = MP_MESSAGE) and CanSubPart then
begin
Mime := AddSubPart;
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
Mime.Lines.Add(s);
end;
Mime.DecomposeParts;
end
else
begin
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
FPartBody.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
//extract postpart
if FPrimaryCode = MP_MULTIPART then
begin
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
FPostPart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
end;
procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar);
var
x: integer;
s: ANSIString;
Mime: TMimePart;
BOP: PANSIChar; // Beginning of Part
EOP: PANSIChar; // End of Part
function ___HasUUCode(ALines:TStrings): boolean;
var
x: integer;
begin
Result := FALSE;
for x:=0 to ALines.Count-1 do
if IsUUcode(ALInes[x]) then
begin
Result := TRUE;
exit;
end;
end;
begin
FBinaryDecomposer := true;
Clear;
// Parse passed headers (THTTPSend returns HTTP headers and body separately)
x := 0;
while x<AHeader.Count do
begin
s := NormalizeHeader(AHeader,x);
if s = '' then
Break;
FHeaders.Add(s);
end;
DecodePartHeader;
// Extract prepart
if FPrimaryCode=MP_MULTIPART then
begin
CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPrePart,FBoundary);
FAttachInside := FAttachInside or ___HasUUCode(FPrePart);
end;
// Extract body part
if FPrimaryCode=MP_MULTIPART then
begin
repeat
if CanSubPart then
begin
Mime := AddSubPart;
BOP := AStx;
EOP := SearchForBoundary(AStx,AEtx,FBoundary);
CopyLinesFromStreamUntilNullLine(BOP,EOP,Mime.Lines);
Mime.DecomposePartsBinary(Mime.Lines,BOP,EOP);
end
else
begin
EOP := SearchForBoundary(AStx,AEtx,FBoundary);
FPartBody.Add(BuildStringFromBuffer(AStx,EOP));
end;
//
BOP := MatchLastBoundary(EOP,AEtx,FBoundary);
if Assigned(BOP) then
begin
AStx := BOP;
Break;
end;
until FALSE;
end;
// Extract nested MIME message
if (FPrimaryCode=MP_MESSAGE) and CanSubPart then
begin
Mime := AddSubPart;
SkipNullLines(AStx,AEtx);
CopyLinesFromStreamUntilNullLine(AStx,AEtx,Mime.Lines);
Mime.DecomposePartsBinary(Mime.Lines,AStx,AEtx);
end
// Extract body of single part
else
begin
FPartBody.Add(BuildStringFromBuffer(AStx,AEtx));
FAttachInside := FAttachInside or ___HasUUCode(FPartBody);
end;
// Extract postpart
if FPrimaryCode=MP_MULTIPART then
begin
CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPostPart,'');
FAttachInside := FAttachInside or ___HasUUCode(FPostPart);
end;
end;
{/pf}
{==============================================================================}
procedure TMIMEPart.ComposeParts;
var
n: integer;
mime: TMimePart;
s, t: string;
d1, d2, d3: integer;
x: integer;
begin
FLines.Clear;
//add headers
for n := 0 to FHeaders.Count -1 do
begin
s := FHeaders[n];
repeat
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('; ', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
d3 := RPosEx(', ', s, FMaxLineLength);
if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
begin
x := Pos(' ', Copy(s, 2, Length(s) - 1));
if x < 1 then
x := Length(s);
end
else
if d1 > 0 then
x := d1
else
if d3 > 0 then
x := d3
else
x := d2 - 1;
t := Copy(s, 1, x);
Delete(s, 1, x);
end;
Flines.Add(t);
until s = '';
end;
Flines.Add('');
//add body
//if multipart
if FPrimaryCode = MP_MULTIPART then
begin
Flines.AddStrings(FPrePart);
for n := 0 to GetSubPartCount - 1 do
begin
Flines.Add('--' + FBoundary);
mime := GetSubPart(n);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
end;
Flines.Add('--' + FBoundary + '--');
Flines.AddStrings(FPostPart);
end;
//if message
if FPrimaryCode = MP_MESSAGE then
begin
if GetSubPartCount > 0 then
begin
mime := GetSubPart(0);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
end;
end
else
//if normal part
begin
FLines.AddStrings(FPartBody);
end;
end;
{==============================================================================}
procedure TMIMEPart.DecodePart;
var
n: Integer;
s, t, t2: string;
b: Boolean;
begin
FDecodedLines.Clear;
{pf}
// The part decomposer passes data via TStringList which appends trailing line
// break inherently. But in a case of native 8-bit data transferred withouth
// encoding (default e.g. for HTTP protocol), the redundant line terminators
// has to be removed
if FBinaryDecomposer and (FPartBody.Count=1) then
begin
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody[0]);
ME_BASE64:
s := DecodeBase64(FPartBody[0]);
ME_UU, ME_XX:
begin
s := '';
for n := 0 to FPartBody.Count - 1 do
if FEncodingCode = ME_UU then
s := s + DecodeUU(FPartBody[n])
else
s := s + DecodeXX(FPartBody[n]);
end;
else
s := FPartBody[0];
end;
end
else
{/pf}
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody.Text);
ME_BASE64:
s := DecodeBase64(FPartBody.Text);
ME_UU, ME_XX:
begin
s := '';
for n := 0 to FPartBody.Count - 1 do
if FEncodingCode = ME_UU then
s := s + DecodeUU(FPartBody[n])
else
s := s + DecodeXX(FPartBody[n]);
end;
else
s := FPartBody.Text;
end;
if FConvertCharset and (FPrimaryCode = MP_TEXT) then
if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
begin
b := false;
t2 := uppercase(s);
t := SeparateLeft(t2, '</HEAD>');
if length(t) <> length(s) then
begin
t := SeparateRight(t, '<HEAD>');
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end;
//workaround for shitty M$ Outlook 11 which is placing this information
//outside <head> section
if not b then
begin
t := Copy(t2, 1, 2048);
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end;
if not b then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end
else
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
WriteStrToStream(FDecodedLines, s);
FDecodedLines.Position := 0;
end;
{==============================================================================}
procedure TMIMEPart.DecodePartHeader;
var
n: integer;
s, su, fn: string;
st, st2: string;
begin
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := FDefaultCharset;
FFileName := '';
//was 7bit before, but this is more compatible with RFC-ignorant outlook
Encoding := '8BIT';
FDisposition := '';
FContentID := '';
fn := '';
for n := 0 to FHeaders.Count - 1 do
if FHeaders[n] <> '' then
begin
s := FHeaders[n];
su := UpperCase(s);
if Pos('CONTENT-TYPE:', su) = 1 then
begin
st := Trim(SeparateRight(su, ':'));
st2 := Trim(SeparateLeft(st, ';'));
Primary := Trim(SeparateLeft(st2, '/'));
FSecondary := Trim(SeparateRight(st2, '/'));
if (FSecondary = Primary) and (Pos('/', st2) < 1) then
FSecondary := '';
case FPrimaryCode of
MP_TEXT:
begin
Charset := UpperCase(GetParameter(s, 'charset'));
FFileName := GetParameter(s, 'name');
end;
MP_MULTIPART:
FBoundary := GetParameter(s, 'Boundary');
MP_MESSAGE:
begin
end;
MP_BINARY:
FFileName := GetParameter(s, 'name');
end;
end;
if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
Encoding := Trim(SeparateRight(su, ':'));
if Pos('CONTENT-DESCRIPTION:', su) = 1 then
FDescription := Trim(SeparateRight(s, ':'));
if Pos('CONTENT-DISPOSITION:', su) = 1 then
begin
FDisposition := SeparateRight(su, ':');
FDisposition := Trim(SeparateLeft(FDisposition, ';'));
fn := GetParameter(s, 'FileName');
end;
if Pos('CONTENT-ID:', su) = 1 then
FContentID := Trim(SeparateRight(s, ':'));
end;
if fn <> '' then
FFileName := fn;
FFileName := InlineDecode(FFileName, FTargetCharset);
FFileName := ExtractFileName(FFileName);
end;
{==============================================================================}
procedure TMIMEPart.EncodePart;
var
l: TStringList;
{$IFDEF UNICODE}
s, t: RawByteString;
{$ELSE}
s, t: string;
{$ENDIF}
n, x: Integer;
d1, d2: integer;
begin
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64';
l := CreateStringList;
FPartBody.Clear;
FDecodedLines.Position := 0;
try
case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE:
FPartBody.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY:
begin
s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode);
if FEncodingCode = ME_BASE64 then
begin
x := 1;
while x <= length(s) do
begin
t := copy(s, x, 54);
x := x + length(t);
t := EncodeBase64(t);
FPartBody.Add(t);
end;
end
else
begin
if FPrimaryCode = MP_BINARY then
l.Add(s)
else
l.Text := s;
for n := 0 to l.Count - 1 do
begin
s := l[n];
if FEncodingCode = ME_QUOTED_PRINTABLE then
begin
s := EncodeQuotedPrintable(s);
repeat
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('=', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
if (d1 = 0) and (d2 = 0) then
x := FMaxLineLength
else
if d1 > d2 then
x := d1 - 1
else
x := d2 - 1;
if x = 0 then
x := FMaxLineLength;
t := Copy(s, 1, x);
Delete(s, 1, x);
if s <> '' then
t := t + '=';
end;
FPartBody.Add(t);
until s = '';
end
else
FPartBody.Add(s);
end;
if (FPrimaryCode = MP_BINARY)
and (FEncodingCode = ME_QUOTED_PRINTABLE) then
FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
end;
end;
end;
finally
l.Free;
end;
end;
{==============================================================================}
procedure TMIMEPart.EncodePartHeader;
var
s: string;
begin
FHeaders.Clear;
if FSecondary = '' then
case FPrimaryCode of
MP_TEXT:
FSecondary := 'plain';
MP_MULTIPART:
FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end;
if FDescription <> '' then
FHeaders.Insert(0, 'Content-Description: ' + FDescription);
if FDisposition <> '' then
begin
s := '';
if FFileName <> '' then
s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then
FHeaders.Insert(0, 'Content-ID: <' + FContentID + '>');
case FEncodingCode of
ME_7BIT:
s := '7bit';
ME_8BIT:
s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end;
case FPrimaryCode of
MP_TEXT,
MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s);
end;
case FPrimaryCode of
MP_TEXT:
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
MP_MESSAGE, MP_BINARY:
s := FPrimary + '/' + FSecondary;
end;
if FFileName <> '' then
s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
FHeaders.Insert(0, 'Content-type: ' + s);
end;
{==============================================================================}
procedure TMIMEPart.MimeTypeFromExt(Value: string);
var
s: string;
n: Integer;
begin
Primary := '';
FSecondary := '';
s := UpperCase(ExtractFileExt(Value));
if s = '' then
s := UpperCase(Value);
s := SeparateRight(s, '.');
for n := 0 to MaxMimeType do
if MimeType[n, 0] = s then
begin
Primary := MimeType[n, 1];
FSecondary := MimeType[n, 2];
Break;
end;
if Primary = '' then
Primary := 'application';
if FSecondary = '' then
FSecondary := 'octet-stream';
end;
{==============================================================================}
procedure TMIMEPart.WalkPart;
var
n: integer;
m: TMimepart;
begin
if assigned(OnWalkPart) then
begin
OnWalkPart(self);
for n := 0 to GetSubPartCount - 1 do
begin
m := GetSubPart(n);
m.OnWalkPart := OnWalkPart;
m.WalkPart;
end;
end;
end;
{==============================================================================}
procedure TMIMEPart.SetPrimary(Value: string);
var
s: string;
begin
FPrimary := Value;
s := UpperCase(Value);
FPrimaryCode := MP_BINARY;
if Pos('TEXT', s) = 1 then
FPrimaryCode := MP_TEXT;
if Pos('MULTIPART', s) = 1 then
FPrimaryCode := MP_MULTIPART;
if Pos('MESSAGE', s) = 1 then
FPrimaryCode := MP_MESSAGE;
end;
procedure TMIMEPart.SetEncoding(Value: string);
var
s: string;
begin
FEncoding := Value;
s := UpperCase(Value);
FEncodingCode := ME_7BIT;
if Pos('8BIT', s) = 1 then
FEncodingCode := ME_8BIT;
if Pos('QUOTED-PRINTABLE', s) = 1 then
FEncodingCode := ME_QUOTED_PRINTABLE;
if Pos('BASE64', s) = 1 then
FEncodingCode := ME_BASE64;
if Pos('X-UU', s) = 1 then
FEncodingCode := ME_UU;
if Pos('X-XX', s) = 1 then
FEncodingCode := ME_XX;
end;
procedure TMIMEPart.SetCharset(Value: string);
begin
if value <> '' then
begin
FCharset := Value;
FCharsetCode := GetCPFromID(Value);
end;
end;
function TMIMEPart.CanSubPart: boolean;
begin
Result := True;
if FMaxSubLevel <> -1 then
Result := FMaxSubLevel > FSubLevel;
end;
function TMIMEPart.IsUUcode(Value: string): boolean;
begin
Value := UpperCase(Value);
Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> '');
end;
{==============================================================================}
function GenerateBoundary: string;
var
x, y: Integer;
begin
y := GetTick;
x := y;
while TickDelta(y, x) = 0 do
begin
Sleep(1);
x := GetTick;
end;
Randomize;
y := Random(MaxInt);
Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
end;
function CreateStringList: TStringList;
begin
Result := TStringList.Create;
{$IFDEF UNICODE}
Result.WriteBOM := False;
{$ENDIF}
end;
end.