mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 08:19:53 +01:00
3914 lines
123 KiB
ObjectPascal
3914 lines
123 KiB
ObjectPascal
{******************************************************************}
|
|
{* IPMSG.PAS - MIME message classes *}
|
|
{******************************************************************}
|
|
|
|
{ $Id$ }
|
|
|
|
(* ***** BEGIN LICENSE BLOCK *****
|
|
* Version: MPL 1.1
|
|
*
|
|
* The contents of this file are subject to the Mozilla Public License Version
|
|
* 1.1 (the "License"); you may not use this file except in compliance with
|
|
* the License. You may obtain a copy of the License at
|
|
* http://www.mozilla.org/MPL/
|
|
*
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
* for the specific language governing rights and limitations under the
|
|
* License.
|
|
*
|
|
* The Original Code is TurboPower Internet Professional
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 2000-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
*
|
|
* Markus Kaemmerer <mk@happyarts.de> SourceForge: mkaemmerer
|
|
*
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{ Global defines potentially affecting this unit }
|
|
|
|
{$I IPDEFINE.INC}
|
|
|
|
unit IpMsg;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF IP_LAZARUS}
|
|
LCLType,
|
|
LCLIntf,
|
|
FileUtil,
|
|
{$ELSE}
|
|
Windows,
|
|
{$ENDIF}
|
|
Classes,
|
|
SysUtils,
|
|
IpStrms,
|
|
{$IFNDEF IP_LAZARUS}
|
|
//IpSock, //JMN
|
|
{$ENDIF}
|
|
IpUtils,
|
|
IpConst;
|
|
|
|
type
|
|
TIpMimeEncodingMethod = (em7Bit, em8Bit, emBase64, emBinary, emBinHex,
|
|
emQuoted, emUUEncode, emUnknown);
|
|
|
|
|
|
{ TIpMimeEntity }
|
|
type
|
|
TIpCodingProgressEvent = procedure(Sender : TObject; Progress : Byte;
|
|
var Abort : Boolean) of object;
|
|
|
|
{Begin !!.12}
|
|
type
|
|
TIpHeaderTypes = (htBCC, htCC, htControl, htDate, htDispositionNotify,
|
|
htFollowUp, htFrom, htInReplyTo, htKeywords,
|
|
htMessageID, htNewsgroups, htNNTPPostingHost,
|
|
htOrganization, htPath, htPostingHost, htReceived,
|
|
htReferences, htReplyTo, htReturnPath, htSender,
|
|
htSubject, htTo, htUserFields, htXIpro);
|
|
|
|
TIpHeaderInfo = record
|
|
FieldType : TIpHeaderTypes;
|
|
FieldString : string;
|
|
end;
|
|
|
|
const
|
|
IpMaxHeaders = 24;
|
|
|
|
IpHeaderXRef : array [0..IpMaxHeaders - 1] of TIpHeaderInfo =
|
|
((FieldType : htBCC; FieldString : 'BCC'),
|
|
(FieldType : htCC; FieldString : 'CC'),
|
|
(FieldType : htControl; FieldString : 'Control: '),
|
|
(FieldType : htDate; FieldString : 'Date'),
|
|
(FieldType : htDispositionNotify; FieldString : 'Disposition-Notification-To'),
|
|
(FieldType : htFollowUp; FieldString : 'Followup-To: '),
|
|
(FieldType : htFrom; FieldString : 'From'),
|
|
(FieldType : htInReplyTo; FieldString : 'In-Reply-To'),
|
|
(FieldType : htKeywords; FieldString : 'Keywords'),
|
|
(FieldType : htMessageID; FieldString : 'Message-ID'),
|
|
(FieldType : htNewsgroups; FieldString : 'Newsgroups'),
|
|
(FieldType : htNNTPPostingHost; FieldString : 'NNTP-Posting-Host'),
|
|
(FieldType : htOrganization; FieldString : 'Organization'),
|
|
(FieldType : htPath; FieldString : 'Path'),
|
|
(FieldType : htPostingHost; FieldString : 'Posting-Host'),
|
|
(FieldType : htReceived; FieldString : 'Received'),
|
|
(FieldType : htReferences; FieldString : 'References'),
|
|
(FieldType : htReplyTo; FieldString : 'Reply-To'),
|
|
(FieldType : htReturnPath; FieldString : 'Return-Path'),
|
|
(FieldType : htSender; FieldString : 'Sender'),
|
|
(FieldType : htSubject; FieldString : 'Subject'),
|
|
(FieldType : htTo; FieldString : 'To'),
|
|
(FieldType : htUserFields; FieldString : 'X-'),
|
|
(FieldType : htXIpro; FieldString : 'X-Ipro'));
|
|
|
|
type
|
|
TIpHeaderCollection = class;
|
|
|
|
TIpHeaderItem = class (TCollectionItem)
|
|
private
|
|
FCollection : TIpHeaderCollection;
|
|
FName : string;
|
|
FNameL : string;
|
|
{ Lower case version of FName. Used to speed up header searches. }
|
|
FProperty : Boolean; {!!.13}
|
|
FValue : TStringList;
|
|
protected
|
|
procedure SetName(const Name : string);
|
|
procedure SetValue (v : TStringList);
|
|
public
|
|
constructor Create (Collection : TCollection); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Collection : TIpHeaderCollection
|
|
read FCollection write FCollection;
|
|
property Name : string read FName write SetName;
|
|
property NameL : string read FNameL;
|
|
{ Lower case version of Name property. }
|
|
property IsProperty : Boolean read FProperty write FProperty; {!!.13}
|
|
{ Set to True if this header is exposed via an iPRO property. }{!!.13}
|
|
property Value : TStringList read FValue write SetValue;
|
|
end;
|
|
|
|
TIpHeaderCollection = class (TCollection)
|
|
private
|
|
FOwner : TPersistent;
|
|
|
|
protected
|
|
function GetItem (Index : Integer) : TIpHeaderItem;
|
|
function GetOwner : TPersistent; override;
|
|
procedure SetItem (Index : Integer; Value : TIpHeaderItem);
|
|
|
|
public
|
|
constructor Create (AOwner : TPersistent);
|
|
|
|
{$IFNDEF VERSION5}
|
|
procedure Delete (Item : integer);
|
|
{$ENDIF}
|
|
function HasHeader (AName : string) : Integer;
|
|
procedure HeaderByName (AName : string;
|
|
Headers : TStringList);
|
|
procedure LoadHeaders (AHeaderList : TStringList;
|
|
Append : Boolean);
|
|
|
|
property Items[Index : Integer] : TIpHeaderItem
|
|
read GetItem write SetItem;
|
|
end;
|
|
{End !!.12}
|
|
|
|
TIpMimeParts = class; { Forwards }
|
|
|
|
TIpMimeEntity = class(TPersistent)
|
|
protected {private}
|
|
FProgress : Byte;
|
|
PrevProgress : Byte;
|
|
FMimeParts : TIpMimeParts;
|
|
FParentBoundary : string;
|
|
FBody : TIpAnsiTextStream;
|
|
FEntityName : string;
|
|
FBoundary : string;
|
|
FCharacterSet : string;
|
|
FContentDescription : string;
|
|
FContentDispositionType : string;
|
|
FContentID : string;
|
|
FContentSubtype : string;
|
|
FContentType : string;
|
|
FCreationDate : string;
|
|
FContentTransferEncoding : TIpMimeEncodingMethod;
|
|
FFileName : string;
|
|
FIsMime : Boolean;
|
|
FIsMultipart : Boolean;
|
|
FModificationDate : string;
|
|
FMimeVersion : string;
|
|
FOnCodingProgress : TIpCodingProgressEvent;
|
|
FOriginalSize : Longint;
|
|
FParent : TIpMimeEntity;
|
|
FReadDate : string;
|
|
FRelatedType : string; {!!.02}
|
|
FRelatedSubtype : string; {!!.02}
|
|
FRelatedStart : string; {!!.02}
|
|
FRelatedStartInfo : string; {!!.02}
|
|
FAttachmentCount : Integer; {!!.12}
|
|
|
|
protected {methods}
|
|
procedure Clear; virtual;
|
|
procedure ClearBodyLargeAttach(const AttachmentSize : Longint); virtual; {!!.12}
|
|
function ContainsSpecialChars(const Value : string) : Boolean; {!!.14}
|
|
procedure DecodeContentDisposition(const aDisp : string);
|
|
procedure DecodeContentType(const aType : string);
|
|
function DecodeContentTransferEncoding(const aEncoding : string) :
|
|
TIpMimeEncodingMethod;
|
|
procedure DecodeMimeHeaders(RawHeaders : TStringlist);
|
|
procedure DoOnCodingProgress(Count, TotalSize : Longint; var Abort : Boolean);
|
|
procedure EncodeContentDisposition(RawHeaders : TStringList);
|
|
procedure EncodeContentType(RawHeaders : TStringList);
|
|
procedure EncodeContentTransferEncoding(RawHeaders : TStringList);
|
|
procedure EncodeMimeHeaders(RawHeaders : TStringlist);
|
|
procedure OctetStreamToHextetStream(InStream : TStream; OutStream : TIpAnsiTextStream;
|
|
const Table; PadChar, Delim : AnsiChar);
|
|
procedure Decode8Bit(OutStream : TStream);
|
|
procedure DecodeBase64(OutStream : TStream);
|
|
procedure DecodeBinHex(OutStream : TStream);
|
|
procedure DecodeQuoted(OutStream : TStream);
|
|
procedure DecodeUUEncode(OutStream : TStream);
|
|
procedure Encode8Bit(InStream : TStream);
|
|
procedure EncodeBase64(InStream : TStream);
|
|
procedure EncodeBinHex(InStream : TStream; const aFileName : string);
|
|
procedure EncodeQuoted(InStream : TStream);
|
|
procedure EncodeUUEncode(InStream : TStream; const aFileName : string);
|
|
function DecodeEntity(InStream : TIpAnsiTextStream) : string;
|
|
function DecodeEntityAsAttachment(InStream : TIpAnsiTextStream) : string; {!!.01}
|
|
function EncodeEntity(OutStream : TIpAnsiTextStream) : string;
|
|
procedure ReadBody(InStream : TIpAnsiTextStream; const StartLine : string); {!!.12}
|
|
|
|
protected {properties}
|
|
property OnCodingProgress : TIpCodingProgressEvent
|
|
read FOnCodingProgress write FOnCodingProgress;
|
|
|
|
public {methods}
|
|
constructor Create(ParentEntity : TIpMimeEntity); virtual;
|
|
destructor Destroy; override;
|
|
procedure ClearBody;
|
|
procedure EncodeBodyFile(const InFile : string);
|
|
procedure EncodeBodyStream(InStream : TStream; const aFileName : string);
|
|
procedure EncodeBodyStrings(InStrings : TStrings; const aFileName : string);
|
|
procedure ExtractBodyFile(const OutFile : string);
|
|
procedure ExtractBodyStream(OutStream : TStream);
|
|
procedure ExtractBodyStrings(OutStrings : TStrings);
|
|
function FindNestedMimePart(const aType, aSubType, aContentID : string) : TIpMimeEntity; {!!.02}
|
|
function GetMimePart(const aType, aSubType, aContentID : string;
|
|
CanCreate : Boolean) : TIpMimeEntity;
|
|
function NewMimePart : TIpMimeEntity;
|
|
|
|
property AttachmentCount : Integer read FAttachmentCount; {!!.12}
|
|
|
|
public {properties}
|
|
property Body : TIpAnsiTextStream
|
|
read FBody;
|
|
|
|
property Boundary : string
|
|
read FBoundary write FBoundary;
|
|
|
|
property CharacterSet : string
|
|
read FCharacterSet write FCharacterSet;
|
|
|
|
property ContentDescription : string
|
|
read FContentDescription write FContentDescription;
|
|
|
|
property ContentDispositionType : string
|
|
read FContentDispositionType write FContentDispositionType;
|
|
|
|
property ContentID : string
|
|
read FContentID write FContentID;
|
|
|
|
property ContentSubtype : string
|
|
read FContentSubtype write FContentSubtype;
|
|
|
|
property ContentTransferEncoding : TIpMimeEncodingMethod
|
|
read FContentTransferEncoding write FContentTransferEncoding;
|
|
|
|
property ContentType : string
|
|
read FContentType write FContentType;
|
|
|
|
property CreationDate : string
|
|
read FCreationDate write FCreationDate;
|
|
|
|
property EntityName : string
|
|
read FEntityName write FEntityName;
|
|
|
|
property FileName : string
|
|
read FFileName write FFileName;
|
|
|
|
property IsMime : Boolean
|
|
read FIsMime;
|
|
|
|
property IsMultipart : Boolean
|
|
read FIsMultipart;
|
|
|
|
property MimeParts : TIpMimeParts
|
|
read FMimeParts;
|
|
|
|
property MimeVersion : string
|
|
read FMimeVersion write FMimeVersion;
|
|
|
|
property ModificationDate : string
|
|
read FModificationDate write FModificationDate;
|
|
|
|
property OriginalSize : Longint
|
|
read FOriginalSize write FOriginalSize;
|
|
|
|
property Parent : TIpMimeEntity
|
|
read FParent;
|
|
|
|
property ReadDate : string
|
|
read FReadDate write FReadDate;
|
|
|
|
property RelatedStart : string {!!.02}
|
|
read FRelatedStart write FRelatedStart;
|
|
|
|
property RelatedStartInfo : string {!!.02}
|
|
read FRelatedStartInfo write FRelatedStartInfo;
|
|
|
|
property RelatedSubtype : string {!!.02}
|
|
read FRelatedSubtype write FRelatedSubtype;
|
|
|
|
property RelatedType : string {!!.02}
|
|
read FRelatedType write FRelatedType;
|
|
|
|
end;
|
|
|
|
|
|
{ TIpMimeParts }
|
|
TIpMimeParts = class
|
|
protected {private}
|
|
Entitys : TList;
|
|
function GetCount : Integer;
|
|
function GetPart(aIndex : Integer) : TIpMimeEntity;
|
|
public {methods}
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add(aEntity : TIpMimeEntity) : Integer;
|
|
function Remove(aEntity : TIpMimeEntity) : Integer;
|
|
procedure Clear;
|
|
procedure Delete(aIndex : Integer);
|
|
function IndexOf(aEntity : TIpMimeEntity) : Integer;
|
|
public {properties}
|
|
property Count : Integer
|
|
read GetCount;
|
|
property Parts[aIndex : Integer] : TIpMimeEntity
|
|
read GetPart; default;
|
|
end;
|
|
|
|
|
|
{ TIpMessage }
|
|
type
|
|
TIpMessage = class(TIpMimeEntity)
|
|
protected {private}
|
|
MsgStream : TIpAnsiTextStream;
|
|
|
|
protected {property variables}
|
|
FBCC : TStringList;
|
|
FCC : TStringList;
|
|
FDate : string;
|
|
FFrom : string;
|
|
FInReplyTo : string;
|
|
FKeywords : string;
|
|
FFollowupTo : string; {!!.12}
|
|
FControl : string; {!!.12}
|
|
FMessageID : string;
|
|
FMessageTag : Integer;
|
|
FNewsgroups : TStringList;
|
|
FNNTPPostingHost : string;
|
|
FOrganization : string;
|
|
FPath : TStringList;
|
|
FPostingHost : string;
|
|
FReceived : TStringList;
|
|
FRecipients : TStringList;
|
|
FReferences : TStringList;
|
|
FReplyTo : string;
|
|
FReturnPath : string;
|
|
FSender : string;
|
|
FSubject : string;
|
|
FUserFields : TStringList;
|
|
FHeaders : TIpHeaderCollection; {!!.12}
|
|
FDispositionNotify: string;
|
|
|
|
protected {methods}
|
|
procedure CheckAllHeaders; {!!.12}
|
|
procedure CheckHeaderType (HeaderInfo : TIpHeaderItem; {!!.12}
|
|
HeaderType : TIpHeaderTypes); {!!.12}
|
|
procedure Clear; override;
|
|
procedure NewMessageStream;
|
|
function GetPosition : Longint;
|
|
function GetSize : Longint;
|
|
procedure SetPosition(Value : Longint);
|
|
procedure SetBCC(const Value: TStringList);
|
|
procedure SetCC(const Value: TStringList);
|
|
procedure SetNewsgroups(const Value: TStringList);
|
|
procedure SetPath(const Value: TStringList);
|
|
procedure SetReceived(const Value: TStringList);
|
|
procedure SetRecipients(const Value: TStringList);
|
|
procedure SetReferences(const Value: TStringlist);
|
|
procedure SetUserFields(const Value: TStringList);
|
|
|
|
public {methods}
|
|
constructor CreateMessage; virtual;
|
|
destructor Destroy; override;
|
|
|
|
procedure AddDefaultAttachment(const aFileName : string); {!!.02}
|
|
procedure AddDefaultAttachmentAs (const aFileName : string; {!!.12}
|
|
const AttachmentName : string); {!!.12}
|
|
procedure Assign(Source : TPersistent); override;
|
|
function AtEndOfStream : Boolean;
|
|
procedure DecodeMessage; virtual;
|
|
procedure EncodeMessage; virtual;
|
|
function GetBodyHtml(CanCreate : Boolean) : TIpMimeEntity;
|
|
function GetBodyPlain(CanCreate : Boolean) : TIpMimeEntity;
|
|
procedure LoadFromFile(const aFileName : string);
|
|
procedure LoadFromStream(aStream : TStream); {!!.12}
|
|
procedure NewMessage;
|
|
function ReadLine : string;
|
|
function ReadLineCRLF : string;
|
|
procedure SaveToFile(const aFileName : string);
|
|
procedure SaveToStream(Stream: TStream); {!!.12}
|
|
procedure SetHeaders(Headers : TIpHeaderCollection); {!!.12}
|
|
procedure WriteLine(const aSt : string);
|
|
|
|
public {properties}
|
|
property BCC : TStringList
|
|
read FBCC write SetBCC; {!!.01}
|
|
|
|
property CC : TStringList
|
|
read FCC write SetCC; {!!.01}
|
|
|
|
property Control : string {!!.12}
|
|
read FControl write FControl; {!!.12}
|
|
|
|
property Date : string
|
|
read FDate write FDate;
|
|
|
|
property DispositionNotification : string {!!.12}
|
|
read FDispositionNotify write FDispositionNotify; {!!.12}
|
|
|
|
property FollowupTo : String {!!.12}
|
|
read FFollowupTo Write FFollowupTo; {!!.12}
|
|
|
|
property From : string
|
|
read FFrom write FFrom;
|
|
|
|
property Headers : TIpHeaderCollection {!!.12}
|
|
read FHeaders write SetHeaders; {!!.12}
|
|
|
|
property InReplyTo : string
|
|
read FInReplyTo write FInReplyTo;
|
|
|
|
property Keywords : string
|
|
read FKeywords write FKeywords;
|
|
|
|
property MessageID : string
|
|
read FMessageID write FMessageID;
|
|
|
|
property MessageStream : TIpAnsiTextStream {!!.03}
|
|
read MsgStream; {!!.03}
|
|
|
|
property MessageTag : Integer
|
|
read FMessageTag write FMessageTag;
|
|
|
|
property Newsgroups : TStringList
|
|
read FNewsgroups write SetNewsgroups; {!!.01}
|
|
|
|
property NNTPPostingHost : string
|
|
read FNNTPPostingHost write FNNTPPostingHost;
|
|
|
|
property Organization : string
|
|
read FOrganization write FOrganization;
|
|
|
|
property Path : TStringList
|
|
read FPath write SetPath; {!!.01}
|
|
|
|
property Position : Longint
|
|
read GetPosition write SetPosition;
|
|
|
|
property PostingHost : string
|
|
read FPostingHost write FPostingHost;
|
|
|
|
property Received : TStringList
|
|
read FReceived write SetReceived; {!!.01}
|
|
|
|
property Recipients : TStringList
|
|
read FRecipients write SetRecipients; {!!.01}
|
|
|
|
property References : TStringlist
|
|
read FReferences write SetReferences; {!!.01}
|
|
|
|
property ReplyTo : string
|
|
read FReplyTo write FReplyTo;
|
|
|
|
property ReturnPath : string
|
|
read FReturnPath write FReturnPath;
|
|
|
|
property Sender : string
|
|
read FSender write FSender;
|
|
|
|
property Size : Longint
|
|
read GetSize;
|
|
|
|
property Subject : string
|
|
read FSubject write FSubject;
|
|
|
|
property UserFields : TStringList
|
|
read FUserFields write SetUserFields; {!!.01}
|
|
|
|
end;
|
|
|
|
|
|
{ TIpMailMessage}
|
|
type
|
|
TIpMailMessage = class(TIpMessage)
|
|
published {properties}
|
|
property BCC;
|
|
property CC;
|
|
property ContentDescription;
|
|
property ContentTransferEncoding;
|
|
property ContentType;
|
|
property Date;
|
|
property From;
|
|
property Keywords;
|
|
property MailTo : TStringList
|
|
read FRecipients write SetRecipients; {!!.01}
|
|
property OnCodingProgress;
|
|
property References;
|
|
property ReplyTo;
|
|
property Sender;
|
|
property Subject;
|
|
property UserFields;
|
|
end;
|
|
|
|
|
|
{ TIpNewsArticle }
|
|
type
|
|
TIpNewsArticle = class(TIpMessage)
|
|
published {properties}
|
|
property ContentDescription;
|
|
property ContentTransferEncoding;
|
|
property ContentType;
|
|
property Date;
|
|
property From;
|
|
property Keywords;
|
|
property Newsgroups;
|
|
property NNTPPostingHost;
|
|
property OnCodingProgress;
|
|
property Path;
|
|
property References;
|
|
property ReplyTo;
|
|
property Sender;
|
|
property Subject;
|
|
property UserFields;
|
|
end;
|
|
|
|
|
|
{ TIpFormDataEntity }
|
|
type
|
|
TIpFormDataEntity = class(TIpMimeEntity)
|
|
protected
|
|
FFilesEntity : TIpMimeEntity;
|
|
public {methods}
|
|
constructor Create(ParentEntity : TIpMimeEntity); override;
|
|
destructor Destroy; override;
|
|
procedure AddFormData(const aName, aText : string);
|
|
procedure AddFile(const aFileName, aContentType, aSubtype : string;
|
|
aEncoding : TIpMimeEncodingMethod);
|
|
procedure SaveToStream(aStream : TStream);
|
|
end;
|
|
|
|
{$IFNDEF IP_LAZARUS}
|
|
{ dummy class so this unit will be added to the uses clause when an }
|
|
{ IpPop3Client, IpSmtpClient or IpNntpClient component is dropped on the form }
|
|
(*** //JMN
|
|
TIpCustomEmailClass = class(TIpCustomClient)
|
|
end;
|
|
**)
|
|
{$ENDIF}
|
|
|
|
function IpBase64EncodeString(const InStr: string): string; {!!.02}{!!.03}
|
|
|
|
{Begin !!.12}
|
|
const
|
|
IpLgAttachSizeBoundry = 5 * 1024 * 1024;
|
|
{ Attachments over this size will be encoded using a TIpMemMapStream for
|
|
greatly improved performance. This boundary also applies to the final
|
|
encoding of messages with large attachments. }
|
|
|
|
implementation
|
|
|
|
const
|
|
{ standard headers }
|
|
strBCC = 'BCC: ';
|
|
strCC = 'CC: ';
|
|
strDate = 'Date: ';
|
|
strDispositionNotify = 'Disposition-Notification-To: ';
|
|
strFrom = 'From: ';
|
|
strInReplyTo = 'In-Reply-To: ';
|
|
strKeywords = 'Keywords: ';
|
|
strMessageID = 'Message-ID: ';
|
|
strNewsgroups = 'Newsgroups: ';
|
|
strNNTPPostingHost = 'NNTP-Posting-Host: ';
|
|
strOrganization = 'Organization: ';
|
|
strPath = 'Path: ';
|
|
strPostingHost = 'Posting-Host: ';
|
|
strReceived = 'Received: ';
|
|
strReferences = 'References: ';
|
|
strReplyTo = 'Reply-To: ';
|
|
strReturnPath = 'Return-Path: ';
|
|
strSender = 'Sender: ';
|
|
strSubject = 'Subject: ';
|
|
strTo = 'To: ';
|
|
strUserFields = 'X-';
|
|
strXIpro = 'X-Ipro: ';
|
|
strFollowUp = 'Followup-To: '; {!!.12}
|
|
strControl = 'Control: '; {!!.12}
|
|
|
|
{Begin !!.13}
|
|
IpMimeHeaders : array [0..5] of string =
|
|
{ List of MIME headers that must be marked as public properties in
|
|
the message's Headers collection. Marking them as a public property
|
|
prevents them from being written out twice if the message is saved
|
|
to a file or stream. }
|
|
(
|
|
'Content-Type',
|
|
'MIME-Version',
|
|
'Content-Transfer-Encoding',
|
|
'Content-Description',
|
|
'Content-ID',
|
|
'Content-Disposition'
|
|
);
|
|
{End !!.13}
|
|
|
|
{ MIME headers }
|
|
strMimeVersion = 'MIME-Version: ';
|
|
strContent = 'Content-';
|
|
strContentBase = strContent + 'Base: ';
|
|
strContentDescription = strContent + 'Description: ';
|
|
strContentDisposition = strContent + 'Disposition: ';
|
|
strContentID = strContent + 'ID: ';
|
|
strContentLanguage = strContent + 'Language: ';
|
|
strContentLocation = strContent + 'Location: ';
|
|
strContentTransferEncoding = strContent + 'Transfer-Encoding: ';
|
|
strContentType = strContent + 'Type: ';
|
|
|
|
{ MIME content types }
|
|
strApplication = 'application';
|
|
strAudio = 'audio';
|
|
strFiles = 'files';
|
|
strFormData = 'form-data';
|
|
strImage = 'image';
|
|
strMessage = 'message';
|
|
strMultiPart = 'multipart';
|
|
strText = 'text';
|
|
strVideo = 'video';
|
|
|
|
{ MIME content subtypes and parameters }
|
|
strBoundary = 'boundary=';
|
|
strCharSet = 'charset=';
|
|
strMixed = 'mixed';
|
|
strName = 'name=';
|
|
strPlain = 'plain';
|
|
strHTML = 'html';
|
|
strOctetStream = 'octet-stream';
|
|
strAlternative = 'alternative';
|
|
strRelated = 'related'; {!!.02}
|
|
|
|
{ MIME content disposition parameters }
|
|
strAttachment = 'attachment';
|
|
strInline = 'inline';
|
|
strCreationDate = 'creation-date=';
|
|
strFilename = 'filename=';
|
|
strModificationDate = 'modification-date=';
|
|
strReadDate = 'read-date=';
|
|
strStart = 'start='; {!!.02}
|
|
strStartInfo = 'start-info='; {!!.02}
|
|
strSize = 'size=';
|
|
strType = 'type='; {!!.02}
|
|
|
|
|
|
{ MIME encoding methods }
|
|
str7Bit = '7bit';
|
|
str8Bit = '8bit';
|
|
strBase64 = 'base64';
|
|
strBinary = 'binary';
|
|
strBinHex = 'binhex';
|
|
strQuoted = 'quoted-printable';
|
|
strUUEncode = 'uuencoded';
|
|
|
|
|
|
{ default MIME content type information }
|
|
{$I IPDEFCT.INC}
|
|
|
|
type
|
|
TIp6BitTable = array[0..63] of AnsiChar;
|
|
|
|
const {- BinHex encoding table }
|
|
IpBinHexTable : TIp6BitTable = (
|
|
'!', '"', '#', '$', '%', '&', '''', '(',
|
|
')', '*', '+', ',', '-', '0', '1', '2',
|
|
'3', '4', '5', '6', '8', '9', '@', 'A',
|
|
'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
|
|
'J', 'K', 'L', 'M', 'N', 'P', 'Q', 'R',
|
|
'S', 'T', 'U', 'V', 'X', 'Y', 'Z', '[',
|
|
'`', 'a', 'b', 'c', 'd', 'e', 'f', 'h',
|
|
'i', 'j', 'k', 'l', 'm', 'p', 'q', 'r');
|
|
|
|
const {-BinHex decoding table }
|
|
IpHexBinTable : array[33..114] of Byte = (
|
|
$00, $01, $02, $03, $04, $05, $06, $07,
|
|
$08, $09, $0A, $0B, $0C, $FF, $FF, $0D,
|
|
$0E, $0F, $10, $11, $12, $13, $FF, $14,
|
|
$15, $FF, $FF, $FF, $FF, $FF, $FF, $16,
|
|
$17, $18, $19, $1A, $1B, $1C, $1D, $1E,
|
|
$1F, $20, $21, $22, $23, $24, $FF, $25,
|
|
$26, $27, $28, $29, $2A, $2B, $FF, $2C,
|
|
$2D, $2E, $2F, $FF, $FF, $FF, $FF, $30,
|
|
$31, $32, $33, $34, $35, $36, $FF, $37,
|
|
$38, $39, $3A, $3B, $3C, $FF, $FF, $3D,
|
|
$3E, $3F);
|
|
|
|
const { Base64 encoding table }
|
|
Ip64Table : TIp6BitTable = (
|
|
#065, #066, #067, #068, #069, #070, #071, #072,
|
|
#073, #074, #075, #076, #077, #078, #079, #080,
|
|
#081, #082, #083, #084, #085, #086, #087, #088,
|
|
#089, #090, #097, #098, #099, #100, #101, #102,
|
|
#103, #104, #105, #106, #107, #108, #109, #110,
|
|
#111, #112, #113, #114, #115, #116, #117, #118,
|
|
#119, #120, #121, #122, #048, #049, #050, #051,
|
|
#052, #053, #054, #055, #056, #057, #043, #047);
|
|
|
|
const { Base64 decoding table }
|
|
IpD64Table : array[#43..#122] of Byte = ( {!!.12}
|
|
$3E, $7F, $7F, $7F, $3F, $34, $35, $36,
|
|
$37, $38, $39, $3A, $3B, $3C, $3D, $7F,
|
|
$7F, $7F, $7F, $7F, $7F, $7F, $00, $01,
|
|
$02, $03, $04, $05, $06, $07, $08, $09,
|
|
$0A, $0B, $0C, $0D, $0E, $0F, $10, $11,
|
|
$12, $13, $14, $15, $16, $17, $18, $19,
|
|
$7F, $7F, $7F, $7F, $7F, $7F, $1A, $1B,
|
|
$1C, $1D, $1E, $1F, $20, $21, $22, $23,
|
|
$24, $25, $26, $27, $28, $29, $2A, $2B,
|
|
$2C, $2D, $2E, $2F, $30, $31, $32, $33);
|
|
|
|
const { UUEncode encoding table }
|
|
IpUUTable : TIp6BitTable = (
|
|
#96, #33, #34, #35, #36, #37, #38, #39,
|
|
#40, #41, #42, #43, #44, #45, #46, #47,
|
|
#48, #49, #50, #51, #52, #53, #54, #55,
|
|
#56, #57, #58, #59, #60, #61, #62, #63,
|
|
#64, #65, #66, #67, #68, #69, #70, #71,
|
|
#72, #73, #74, #75, #76, #77, #78, #79,
|
|
#80, #81, #82, #83, #84, #85, #86, #87,
|
|
#88, #89, #90, #91, #92, #93, #94, #95);
|
|
|
|
const
|
|
HexDigits : array[0..$F] of AnsiChar = '0123456789ABCDEF';
|
|
RLEChar : Byte = $90;
|
|
BinHexFileType : array[0..3] of Byte = ($49, $42, $4D, $3F); { "IBM?" }
|
|
CRLF = #13#10;
|
|
MaxLine = 1000; {!!.12}
|
|
MaxLineEncode = 77; {!!.13}
|
|
{ Maximum line length for QuotablePrintable & Base64 encoding. } {!!.13}
|
|
|
|
type
|
|
BinHexHeader = packed record
|
|
Version : Byte;
|
|
FileType : array[0..3] of Byte;
|
|
Creator : array[0..3] of Byte;
|
|
Flags : Word;
|
|
DFLong : Longint;
|
|
RFLong : Longint;
|
|
end;
|
|
|
|
function IsSameString (Str1 : string; {!!.12}
|
|
Str2 : string; {!!.12}
|
|
CaseSensitive : Boolean) : Boolean; {!!.12}
|
|
begin {!!.12}
|
|
if CaseSensitive then {!!.12}
|
|
Result := (Str1 = Str2) {!!.12}
|
|
else {!!.12}
|
|
Result := StrIComp (PChar (Str1), PChar (Str2)) = 0; {!!.12}
|
|
end; {!!.12}
|
|
|
|
{ Parse string into string list }
|
|
procedure Parse(const Line : string; Delim : AnsiChar; var List : TStringList);
|
|
var
|
|
iPos, jPos : Integer;
|
|
Term : string;
|
|
begin
|
|
iPos := 1;
|
|
jPos := IpUtils.CharPos(Delim, Line);
|
|
while (jPos > 0) do begin
|
|
Term := Copy(Line, iPos, jPos - iPos); {!!.02}
|
|
if (Term <> '') then
|
|
List.Add(Trim(Term));
|
|
iPos := jPos + 1;
|
|
jPos := IpUtils.CharPosIdx(Delim, Line, iPos);
|
|
end;
|
|
if (iPos < Length(Line)) then
|
|
List.Add(Trim(Copy(Line, iPos, Length(Line))));
|
|
end;
|
|
|
|
{ Return a particular parameter from a parsed header parameter list }
|
|
procedure DecodeSingleParameter(const ParamName : string;
|
|
RawParams : TStringList;
|
|
var ParamFieldStr : string);
|
|
var
|
|
S : string;
|
|
i, j : Integer;
|
|
begin
|
|
ParamFieldStr := '';
|
|
{find the line containing the parameter field name}
|
|
for i := 1 to RawParams.Count do begin
|
|
S := RawParams[i-1];
|
|
if StrLIComp(PChar(ParamName), PChar(S), Length(ParamName)) = 0 then begin
|
|
{strip off the parameter field name and remove quotes }
|
|
ParamFieldStr := Copy(S, Length(ParamName) + 1, Length(S));
|
|
j := IpUtils.CharPos('"', ParamFieldStr);
|
|
while (j > 0) do begin
|
|
Delete(ParamFieldStr, j, 1);
|
|
j := IpUtils.CharPos('"', ParamFieldStr);
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Return a particular header as string }
|
|
procedure DecodeSingleHeader(const HeaderName : string;
|
|
RawHeaders : TStringList;
|
|
var HeaderFieldStr : string);
|
|
var
|
|
S, S2 : string;
|
|
i, j : Integer;
|
|
begin
|
|
HeaderFieldStr := '';
|
|
{find the line containing the header field name}
|
|
for i := 1 to RawHeaders.Count do begin
|
|
S := RawHeaders[i-1];
|
|
if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
|
|
{strip off the header field name}
|
|
S := Copy(S, Length(HeaderName) + 1, Length(S));
|
|
{unfold the header if continued on more than one line}
|
|
if (i < RawHeaders.Count) then
|
|
for j := i to Pred(RawHeaders.Count) do begin
|
|
S2 := RawHeaders[j];
|
|
if (Length(S2) > 0) and (S2[1] <> #09) and (S2[1] <> ' ') then
|
|
Break
|
|
else
|
|
S := S + S2;
|
|
end;
|
|
HeaderFieldStr := S;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Return a particular header as string list }
|
|
(*procedure DecodeListHeader(const HeaderName : string;
|
|
RawHeaders, HeaderFieldList : TStringList);
|
|
var
|
|
S : string;
|
|
i, j : Integer;
|
|
begin
|
|
{find the line containing the header field name}
|
|
for i := 1 to RawHeaders.Count do begin
|
|
S := RawHeaders[i-1];
|
|
if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
|
|
{strip off the header field name}
|
|
HeaderFieldList.Add(Copy(S, Length(HeaderName) + 1, Length(S)));
|
|
{unfold the header if continued on more than one line}
|
|
if (i < RawHeaders.Count) then
|
|
for j := i to Pred(RawHeaders.Count) do begin
|
|
S := RawHeaders[j];
|
|
if (Length(S) > 0) and (S[1] <> #09) and (S[1] <> ' ') then
|
|
Break
|
|
else
|
|
HeaderFieldList.Add(S);
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;*)
|
|
|
|
{ Return multiple instance headers as string list }
|
|
(*procedure DecodeMultiHeader(const HeaderName : string;
|
|
RawHeaders, HeaderFieldList : TStringList);
|
|
|
|
var
|
|
S, S2 : string;
|
|
i, j : Integer;
|
|
begin
|
|
{find the next line containing the header field name}
|
|
for i := 1 to RawHeaders.Count do begin
|
|
S := RawHeaders[i-1];
|
|
if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
|
|
if HeaderName <> strUserFields then begin {!!.11}
|
|
{strip off the header field name}
|
|
S := Copy(S, Length(HeaderName) + 1, Length(S));
|
|
{unfold the header if continued on more than one line}
|
|
if (i < RawHeaders.Count) then
|
|
for j := i to Pred(RawHeaders.Count) do begin
|
|
S2 := RawHeaders[j];
|
|
if (Length(S2) > 0) and (S2[1] <> #09) and (S2[1] <> ' ') then
|
|
Break
|
|
else
|
|
S := S + S2;
|
|
end;
|
|
end; {!!.11}
|
|
HeaderFieldList.Add(S);
|
|
end;
|
|
end;
|
|
end;*)
|
|
|
|
{ Add header string to raw headers }
|
|
procedure EncodeSingleHeader(const HeaderName : string;
|
|
RawHeaders : TStringList;
|
|
HeaderFieldStr : string);
|
|
begin
|
|
if (HeaderFieldStr <> '') then
|
|
RawHeaders.Add(HeaderName + HeaderFieldStr);
|
|
end;
|
|
|
|
{ Unfold multiple line header and add to raw headers }
|
|
procedure EncodeListHeader(const HeaderName : string;
|
|
RawHeaders, HeaderFieldList : TStringList;
|
|
const Delim : string;
|
|
Fold : Boolean);
|
|
var
|
|
S : string;
|
|
i : Integer;
|
|
begin
|
|
if (HeaderFieldList.Count > 0) then begin
|
|
S := HeaderName;
|
|
for i := 0 to Pred(HeaderFieldList.Count) do begin
|
|
if (Length(S + HeaderFieldList[i]) > MaxLine) then begin
|
|
RawHeaders.Add(S);
|
|
S := #09;
|
|
end;
|
|
S := S + HeaderFieldList[i];
|
|
if (i < HeaderFieldList.Count - 1) and (S <> '') then begin
|
|
S := S + Delim; {!!.14}
|
|
if Fold then begin
|
|
RawHeaders.Add(S);
|
|
S := #09;
|
|
end;
|
|
end;
|
|
end;
|
|
RawHeaders.Add(S);
|
|
end;
|
|
end;
|
|
|
|
{ Add multiple instance header to raw headers }
|
|
procedure EncodeMultiHeader(const HeaderName : string;
|
|
RawHeaders, HeaderFieldList : TStringList;
|
|
Delim : AnsiChar;
|
|
Fold : Boolean);
|
|
var
|
|
i, j : Integer;
|
|
SL : TStringList;
|
|
S : string;
|
|
begin
|
|
if (HeaderFieldList.Count > 0) then
|
|
for j := 1 to HeaderFieldList.Count do begin
|
|
if not Fold then
|
|
RawHeaders.Add(HeaderName + HeaderFieldList[j-1])
|
|
else begin
|
|
SL := TStringList.Create;
|
|
try
|
|
Parse(HeaderFieldList[j-1], Delim, SL);
|
|
S := HeaderName;
|
|
for i := 1 to SL.Count do begin
|
|
S := S + SL[i-1];
|
|
if (i < SL.Count) and (S <> '') then begin
|
|
{Begin !!.13}
|
|
RawHeaders.Add(S);
|
|
S := Delim;
|
|
{End !!.13}
|
|
end;
|
|
end;
|
|
finally
|
|
SL.Free;
|
|
end;
|
|
RawHeaders.Add(S);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Generate "unique" boundary string }
|
|
function GenerateBoundary : string;
|
|
var
|
|
Temp : TDateTime;
|
|
begin
|
|
Temp := Now;
|
|
Randomize;
|
|
Result := '_NextPart_' + IntToHex(Trunc(Temp), 8) + '-' +
|
|
IntToHex(Trunc(Frac(Temp) * 10000), 8) + '-' +
|
|
IntToHex(GetTickCount, 8) + '-' + IntToHex(Random($FFFF), 4);
|
|
end;
|
|
|
|
{ 16-bit CRC of stream between starting and ending offset }
|
|
function BinHexCRC(Stream : TStream; StartOffset, EndOffset : Longint) : Word;
|
|
var
|
|
Crc : Word;
|
|
InByte : Byte;
|
|
ByteStream : TIpByteStream;
|
|
|
|
procedure DoCRC(b : Byte);
|
|
{- carry CRC division on with next byte }
|
|
var
|
|
j : Byte;
|
|
t : Boolean;
|
|
begin
|
|
for j := 1 to 8 do begin
|
|
t := (Crc and $8000) <> 0;
|
|
Crc := (Crc shl 1) xor (b shr 7);
|
|
if t then
|
|
Crc := Crc xor $1021;
|
|
b := b shl 1;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if (StartOffset > Stream.Size) or (EndOffset > Stream.Size) then
|
|
raise EIpBaseException.Create(SBadOffset);
|
|
|
|
Crc := 0;
|
|
Stream.Position := StartOffset;
|
|
ByteStream := TIpByteStream.Create(Stream);
|
|
try
|
|
while (ByteStream.Position < EndOffset) do begin
|
|
if ByteStream.Read(InByte) then
|
|
DoCrc(InByte);
|
|
end;
|
|
finally
|
|
ByteStream.Free;
|
|
end;
|
|
DoCrc(0);
|
|
DoCrc(0);
|
|
Result := Swap(Crc);
|
|
end;
|
|
|
|
{ Reverse bytes and words }
|
|
function htonl(HostLong : Longint) : Longint;
|
|
var
|
|
dw : Longint;
|
|
wa : array[0..1] of Word absolute dw;
|
|
w : Word;
|
|
begin
|
|
dw := HostLong;
|
|
w := wa[0];
|
|
wa[0] := Swap(wa[1]);
|
|
wa[1] := Swap(w);
|
|
Result := dw;
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
{ TIpHeaderItem ****************************************************** }
|
|
|
|
constructor TIpHeaderItem.Create (Collection : TCollection);
|
|
begin
|
|
inherited Create (Collection);
|
|
FCollection := TIpHeaderCollection.Create (
|
|
TIpHeaderCollection(Collection).FOwner);
|
|
|
|
FValue := TStringList.Create;
|
|
FName := '';
|
|
FProperty := False; {!!.13}
|
|
end;
|
|
|
|
destructor TIpHeaderItem.Destroy;
|
|
begin
|
|
FCollection.Free;
|
|
FCollection := nil;
|
|
|
|
FValue.Free;
|
|
FValue := nil;
|
|
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TIpHeaderItem.SetName(const Name : string);
|
|
begin
|
|
FName := Name;
|
|
FNameL := LowerCase(Name);
|
|
end;
|
|
|
|
procedure TIpHeaderItem.SetValue (v : TStringList);
|
|
begin
|
|
FValue.Assign (v);
|
|
end;
|
|
|
|
{ TIpHeaderCollection ************************************************ }
|
|
|
|
constructor TIpHeaderCollection.Create(AOwner : TPersistent);
|
|
begin
|
|
inherited Create (TIpHeaderItem);
|
|
FOwner := AOwner;
|
|
end;
|
|
|
|
{$IFNDEF VERSION5}
|
|
procedure TIpHeaderCollection.Delete(Item: integer);
|
|
begin
|
|
GetItem(Item).Free;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TIpHeaderCollection.GetItem (Index : Integer) : TIpHeaderItem;
|
|
begin
|
|
Result := TIpHeaderItem (inherited GetItem (Index));
|
|
end;
|
|
|
|
function TIpHeaderCollection.GetOwner : TPersistent;
|
|
begin
|
|
Result := FOwner;
|
|
end;
|
|
|
|
function TIpHeaderCollection.HasHeader (AName : string) : Integer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
Result := -1;
|
|
AName := LowerCase(AName);
|
|
for i := 0 to Count - 1 do
|
|
if Items[i].NameL = AName then begin
|
|
Result := i;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TIpHeaderCollection.HeaderByName (AName : string;
|
|
Headers : TStringList);
|
|
var
|
|
HeaderPos : Integer;
|
|
begin
|
|
Headers.Clear;
|
|
HeaderPos := HasHeader (AName);
|
|
if HeaderPos >= 0 then
|
|
Headers.Assign (Items[HeaderPos].Value);
|
|
end;
|
|
|
|
procedure TIpHeaderCollection.LoadHeaders (AHeaderList : TStringList;
|
|
Append : Boolean);
|
|
var
|
|
CurPos : Integer;
|
|
|
|
function ExtractHeaderName (const AName : string) : string;
|
|
{!!.15 - replaced local variable i with inx in order to avoid confusion with
|
|
variable i in parent routine. }
|
|
var
|
|
inx : Integer;
|
|
NameLen : Integer;
|
|
begin
|
|
Result := '';
|
|
CurPos := 0;
|
|
|
|
inx := 0;
|
|
NameLen := Length (AName);
|
|
while (inx < NameLen) and (AName[inx + 1] <> ':') and
|
|
(AName[inx + 1] >= #33) and (AName[inx + 1] <= #126) do
|
|
Inc (inx);
|
|
if (inx > 0) then
|
|
Result := Copy (AName, 1, inx);
|
|
CurPos := inx + 2;
|
|
end;
|
|
|
|
function IsWrappedLine (AHeaderList : TStringList;
|
|
LineToCheck : Integer) : Boolean;
|
|
begin
|
|
if LineToCheck < AHeaderList.Count then begin
|
|
if Length (AHeaderList[LineToCheck]) > 0 then begin
|
|
if (AHeaderList[LineToCheck][1] = ' ') or
|
|
(AHeaderList[LineToCheck][1] = #09) then
|
|
Result := True
|
|
else
|
|
Result := False;
|
|
end else
|
|
Result := False;
|
|
end else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure GetFieldValue ( AHeaderList : TStringList;
|
|
var CurLine : Integer;
|
|
var NewField : TIpHeaderItem);
|
|
var
|
|
WorkLine : string;
|
|
LineLen : Integer;
|
|
|
|
begin
|
|
if CurLine >= AHeaderList.Count then
|
|
Exit;
|
|
LineLen := Length (AHeaderList[CurLine]);
|
|
while (CurPos < LineLen) and
|
|
((AHeaderList[CurLine][CurPos] = ' ') or
|
|
(AHeaderList[CurLine][CurPos] = #09)) do
|
|
Inc (CurPos);
|
|
WorkLine := Copy (AHeaderList[CurLine],
|
|
CurPos, LineLen - CurPos + 1);
|
|
{Begin !!.13}
|
|
Inc(CurLine);
|
|
|
|
while IsWrappedLine (AHeaderList, CurLine) do begin
|
|
WorkLine := WorkLine + #9 + Trim(AHeaderList[CurLine]);
|
|
Inc(CurLine);
|
|
end;
|
|
NewField.Value.Add (Trim (WorkLine));
|
|
{End !!.13}
|
|
end;
|
|
|
|
var
|
|
i : Integer;
|
|
HeaderName : string;
|
|
NewHeader : TIpHeaderItem;
|
|
begin
|
|
if not Append then
|
|
Clear;
|
|
|
|
i := 0;
|
|
while i < AHeaderList.Count do begin
|
|
HeaderName := ExtractHeaderName (AHeaderList[i]);
|
|
if HeaderName <> '' then begin
|
|
NewHeader := TIpHeaderItem (Add);
|
|
NewHeader.Name := HeaderName;
|
|
GetFieldValue (AHeaderList, i, NewHeader);
|
|
{Begin !!.15}
|
|
end
|
|
else
|
|
Inc(i);
|
|
{End !!.15}
|
|
end;
|
|
end;
|
|
|
|
procedure TIpHeaderCollection.SetItem (Index : Integer;
|
|
Value : TIpHeaderItem);
|
|
begin
|
|
inherited SetItem (Index, Value);
|
|
end;
|
|
{End !!.12}
|
|
|
|
{ TIpMimeParts }
|
|
constructor TIpMimeParts.Create;
|
|
begin
|
|
inherited Create;
|
|
Entitys := TList.Create;
|
|
end;
|
|
|
|
destructor TIpMimeParts.Destroy;
|
|
begin
|
|
Clear;
|
|
Entitys.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ Add Mime block to list }
|
|
function TIpMimeParts.Add(aEntity : TIpMimeEntity) : Integer;
|
|
begin
|
|
Result := Entitys.Add(aEntity);
|
|
end;
|
|
|
|
{ Clear list }
|
|
procedure TIpMimeParts.Clear;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := Pred(Entitys.Count) downto 0 do
|
|
Delete(i);
|
|
end;
|
|
|
|
{ Delete block from list }
|
|
procedure TIpMimeParts.Delete(aIndex : Integer);
|
|
begin
|
|
if (aIndex >= 0) and (aIndex < Entitys.Count) then begin
|
|
TIpMimeEntity(Entitys[aIndex]).Free;
|
|
end;
|
|
end;
|
|
|
|
{ Remove block from list }
|
|
function TIpMimeParts.Remove(aEntity : TIpMimeEntity) : Integer;
|
|
begin
|
|
Result := Entitys.Remove(Pointer(aEntity));
|
|
end;
|
|
|
|
{ Count property read access method }
|
|
function TIpMimeParts.GetCount : Integer;
|
|
begin
|
|
Result := Entitys.Count;
|
|
end;
|
|
|
|
{ Parts property read access method }
|
|
function TIpMimeParts.GetPart(aIndex : Integer) : TIpMimeEntity;
|
|
begin
|
|
if (aIndex >= 0) and (aIndex < Entitys.Count) then
|
|
Result := TIpMimeEntity(Entitys[aIndex])
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
{ Returns list index of specified Mime block }
|
|
function TIpMimeParts.IndexOf(aEntity : TIpMimeEntity) : Integer;
|
|
begin
|
|
Result := Entitys.IndexOf(aEntity);
|
|
end;
|
|
|
|
|
|
{ TIpMimeEntity }
|
|
constructor TIpMimeEntity.Create(ParentEntity : TIpMimeEntity);
|
|
begin
|
|
inherited Create;
|
|
FBody := TIpAnsiTextStream.CreateEmpty;
|
|
FBody.Stream := TMemoryStream.Create;
|
|
FMimeParts := TIpMimeParts.Create;
|
|
FParent := ParentEntity;
|
|
if (FParent <> nil) then
|
|
FParentBoundary := FParent.Boundary;
|
|
end;
|
|
|
|
destructor TIpMimeEntity.Destroy;
|
|
begin
|
|
FMimeParts.Free;
|
|
FBody.FreeStream;
|
|
FBody.Free;
|
|
if (FParent <> nil) then
|
|
FParent.MimeParts.Remove(Self);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ Clear Body property }
|
|
procedure TIpMimeEntity.ClearBody;
|
|
begin
|
|
FBody.FreeStream;
|
|
FBody.Stream := TMemoryStream.Create;
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
{ Clear Body property in preparation for large attachment }
|
|
procedure TIpMimeEntity.ClearBodyLargeAttach(const AttachmentSize : Longint);
|
|
var
|
|
FileName : string;
|
|
Strm : TIpMemMapStream;
|
|
begin
|
|
FBody.FreeStream;
|
|
FileName := GetTemporaryFile(GetTemporaryPath);
|
|
if FileExistsUTF8(FileName) then
|
|
DeleteFileUTF8(FileName);
|
|
Strm := TIpMemMapStream.Create(FileName, False, True);
|
|
Strm.Size := Trunc(AttachmentSize * 1.3695);
|
|
Strm.Open;
|
|
FBody.Stream := Strm;
|
|
end;
|
|
{End !!.12}
|
|
|
|
{ Clear all properties }
|
|
procedure TIpMimeEntity.Clear;
|
|
begin
|
|
ClearBody;
|
|
FMimeParts.Clear;
|
|
FBoundary := '';
|
|
FCharacterSet := '';
|
|
FContentDescription := '';
|
|
FContentDispositionType := '';
|
|
FContentID := '';
|
|
FContentSubtype := '';
|
|
FContentType := '';
|
|
FContentTransferEncoding := emUnknown;
|
|
FFileName := '';
|
|
FIsMime := False;
|
|
FIsMultipart := False;
|
|
FMimeVersion := '';
|
|
FEntityName := '';
|
|
FRelatedType := ''; {!!.02}
|
|
FRelatedSubtype := ''; {!!.02}
|
|
FRelatedStart := ''; {!!.02}
|
|
FRelatedStartInfo := ''; {!!.02}
|
|
end;
|
|
|
|
{ Build Mime (and nested Mime) block(s) from incoming text stream }
|
|
function TIpMimeEntity.DecodeEntity(InStream : TIpAnsiTextStream) : string;
|
|
var
|
|
Blk : TIpMimeEntity;
|
|
RawHeaders : TStringList;
|
|
Decoded : Boolean; {!!.12}
|
|
i, {!!.13}
|
|
LeadingBlankLines : Integer; {!!.13}
|
|
begin
|
|
Decoded := False; {!!.12}
|
|
LeadingBlankLines := 0; {!!.13}
|
|
{ skip blank lines in front of mime headers or body }
|
|
Result := InStream.ReadLine;
|
|
while (Result = '') and not InStream.AtEndOfStream do begin
|
|
inc(LeadingBlankLines);
|
|
Result := InStream.ReadLine;
|
|
end;
|
|
|
|
{ decode mime headers if any }
|
|
{Begin !!.15}
|
|
if (StrLIComp(PChar(strContent), PChar(Result), Length(strContent)) = 0) or
|
|
(StrLIComp(PChar(strMimeVersion), PChar(Result),
|
|
Length(strMimeVersion)) = 0) then begin
|
|
{End !!.15}
|
|
RawHeaders := TStringList.Create;
|
|
try
|
|
repeat
|
|
RawHeaders.Add(Result);
|
|
Result := InStream.ReadLine;
|
|
until (Result = '') or (InStream.AtEndOfStream);
|
|
DecodeMimeHeaders(RawHeaders);
|
|
finally
|
|
RawHeaders.Free;
|
|
end;
|
|
Result := InStream.ReadLine;
|
|
{ skip blank lines between mime headers and mime body }
|
|
while (Result = '') and not InStream.AtEndOfStream do
|
|
Result := InStream.ReadLine;
|
|
end;
|
|
|
|
{ decode body - main loop }
|
|
{Begin !!.15}
|
|
if (FParentBoundary <> '') and
|
|
(Result = '--' + FParentBoundary) then
|
|
{ The body of this entity is empty & we are now positioned at the boundary
|
|
marker for the next entity. }
|
|
Decoded := True
|
|
else
|
|
{End !!.15}
|
|
while not (((FParentBoundary <> '') and {!!.12}
|
|
(Result = '--' + FParentBoundary) {!!.12}
|
|
) or InStream.AtEndOfStream) do begin {!!.12}
|
|
Decoded := True;
|
|
{ check for ending boundary - in which case were done }
|
|
if (FParentBoundary <> '') then
|
|
if Pos('--' + FParentBoundary + '--', Result) = 1 {> 0} then begin
|
|
Result := InStream.ReadLine;
|
|
Exit;
|
|
end;
|
|
|
|
{ decode any nested mime parts - recursively }
|
|
if IsMultiPart and (Boundary <> '') and {!!.03}
|
|
(Pos('--' + Boundary, Result) = 1) then begin
|
|
Blk := TIpMimeEntity.Create(Self);
|
|
Result := Blk.DecodeEntity(Instream);
|
|
FMimeParts.Add(Blk);
|
|
end else begin
|
|
{ read raw text line into body }
|
|
for i := 1 to LeadingBlankLines do {!!.13}
|
|
Body.WriteLine(''); {!!.13}
|
|
Body.WriteLine(Result);
|
|
Result := InStream.ReadLine;
|
|
end;
|
|
if InStream.AtEndOfStream then break; {!!.12}
|
|
LeadingBlankLines := 0; {!!.13}
|
|
end;
|
|
{Begin !!.12}
|
|
{ If did not find a MIME entity then assume the body is text &
|
|
read it into the Body property. }
|
|
if not Decoded then
|
|
ReadBody(InStream, Result)
|
|
else if (not (Pos('--' + FParentBoundary, Result) = 1)) then
|
|
{ If the last line is not a MIME separator then add the last line
|
|
to the Body. }
|
|
Body.WriteLine(Result);
|
|
{End !!.12}
|
|
end;
|
|
|
|
{!!.01}
|
|
{ Build Mime block as subpart from incoming text stream }
|
|
function TIpMimeEntity.DecodeEntityAsAttachment(InStream : TIpAnsiTextStream) : string;
|
|
var
|
|
Blk : TIpMimeEntity;
|
|
begin
|
|
Blk := TIpMimeEntity.Create(Self);
|
|
Blk.ContentType := FContentType;
|
|
Blk.ContentSubtype := FContentSubtype;
|
|
Blk.ContentDispositionType := FContentDispositionType;
|
|
Blk.ContentDescription := FContentDescription;
|
|
Blk.ContentTransferEncoding := FContentTransferEncoding;
|
|
Blk.CharacterSet := FCharacterSet;
|
|
Blk.CreationDate := FCreationDate;
|
|
Blk.FileName := FFileName;
|
|
Blk.EntityName := FEntityName;
|
|
Blk.FIsMime := True;
|
|
Blk.FIsMultipart := False;
|
|
Blk.ModificationDate := FModificationDate;
|
|
Blk.MimeVersion := FMimeVersion;
|
|
Blk.OriginalSize := FOriginalSize;
|
|
Blk.ReadDate := FReadDate;
|
|
|
|
Result := Blk.DecodeEntity(Instream);
|
|
FMimeParts.Add(Blk);
|
|
Body.Position := 0;
|
|
end;
|
|
|
|
{ Decode Content-Disposition header field and sub-fields }
|
|
procedure TIpMimeEntity.DecodeContentDisposition(const aDisp : string);
|
|
var
|
|
RawParams : TStringList;
|
|
S : string;
|
|
begin
|
|
{ split up parameters }
|
|
RawParams := TStringList.Create;
|
|
try
|
|
Parse(aDisp, ';', RawParams);
|
|
|
|
{ decode disposition type and parameters }
|
|
if (RawParams.Count > 0) then begin
|
|
FContentDispositionType := RawParams[0];
|
|
if (RawParams.Count > 1) then begin
|
|
DecodeSingleParameter(strFileName, RawParams, FFileName);
|
|
DecodeSingleParameter(strCreationDate, RawParams, FCreationDate);
|
|
DecodeSingleParameter(strModificationDate, RawParams, FModificationDate);
|
|
DecodeSingleParameter(strReadDate, RawParams, FReadDate);
|
|
DecodeSingleParameter(strSize, RawParams, S);
|
|
FOriginalSize := StrToIntDef(S, 0);
|
|
end;
|
|
end else
|
|
FContentDispositionType := '';
|
|
finally
|
|
RawParams.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Decode Content-Type header field and sub-fields }
|
|
procedure TIpMimeEntity.DecodeContentType(const aType : string);
|
|
var
|
|
RawParams : TStringList;
|
|
S : string;
|
|
i : Integer;
|
|
begin
|
|
{ split up parameters }
|
|
RawParams := TStringList.Create;
|
|
try
|
|
Parse(aType, ';', RawParams);
|
|
|
|
{ decode type and subtype }
|
|
FContentType := '';
|
|
FContentSubType := '';
|
|
if (RawParams.Count > 0) then begin
|
|
S := RawParams[0];
|
|
i := IpUtils.CharPos('/', S);
|
|
if (i > 0) then begin
|
|
FContentType := Copy(S, 1, i - 1);
|
|
FContentSubType := Copy(S, i + 1, Length(S));
|
|
end else
|
|
FContentType := S;
|
|
end;
|
|
FIsMultipart := StrIComp(PChar(FContentType), PChar(strMultipart)) = 0;
|
|
|
|
{ decode the parameters }
|
|
DecodeSingleParameter(strName, RawParams, FEntityName);
|
|
DecodeSingleParameter(strBoundary, RawParams, FBoundary);
|
|
DecodeSingleParameter(strCharSet, RawParams, FCharacterSet);
|
|
|
|
{!!.02}
|
|
{ decode multipart/related parameters }
|
|
DecodeSingleParameter(strType, RawParams, S);
|
|
if (S <> '') then begin
|
|
i := IpUtils.CharPos('/', S);
|
|
if (i > 0) then begin
|
|
FRelatedType := Copy(S, 1, i - 1);
|
|
FRelatedSubType := Copy(S, i + 1, Length(S));
|
|
end else
|
|
FRelatedType := S;
|
|
DecodeSingleParameter(strStart, RawParams, FRelatedStart);
|
|
DecodeSingleParameter(strStartInfo, RawParams, FRelatedStartInfo);
|
|
end;
|
|
{!!.02}
|
|
|
|
finally
|
|
RawParams.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Decode Content-TranferEncoding header field }
|
|
function TIpMimeEntity.DecodeContentTransferEncoding(const aEncoding : string) :
|
|
TIpMimeEncodingMethod;
|
|
begin
|
|
if (UpperCase(aEncoding) = UpperCase(str7Bit)) then
|
|
Result := em7bit
|
|
else if (UpperCase(aEncoding) = UpperCase(str8Bit)) then
|
|
Result := em8bit
|
|
else if (UpperCase(aEncoding) = UpperCase(strBase64)) then
|
|
Result := emBase64
|
|
else if (UpperCase(aEncoding) = UpperCase(strBinary)) then
|
|
Result := emBinary
|
|
else if (UpperCase(aEncoding) = UpperCase(strBinHex)) then
|
|
Result := emBinHex
|
|
else if (UpperCase(aEncoding) = UpperCase(strQuoted)) then
|
|
Result := emQuoted
|
|
else if (UpperCase(aEncoding) = UpperCase(strUUEncode)) then
|
|
Result := emUUEncode
|
|
else
|
|
Result := emUnknown;
|
|
end;
|
|
|
|
|
|
{ Decode Mime headers from raw header list }
|
|
procedure TIpMimeEntity.DecodeMimeHeaders(RawHeaders : TStringList);
|
|
var
|
|
S : string;
|
|
begin
|
|
{ decode content type header }
|
|
DecodeSingleHeader(strContentType, RawHeaders, S);
|
|
if (S <> '') then begin
|
|
FIsMime := True;
|
|
DecodeContentType(S);
|
|
if FIsMultipart and (FBoundary = '') then
|
|
raise EIpBaseException.Create(SNoBoundary);
|
|
end else begin
|
|
FIsMime := False;
|
|
Exit;
|
|
end;
|
|
|
|
{ decode the others }
|
|
DecodeSingleHeader(strMIMEVersion, RawHeaders, FMimeVersion);
|
|
DecodeSingleHeader(strContentTransferEncoding, RawHeaders, S);
|
|
FContentTransferEncoding := DecodeContentTransferEncoding(S);
|
|
DecodeSingleHeader(strContentDescription, RawHeaders, FContentDescription);
|
|
DecodeSingleHeader(strContentID, RawHeaders, FContentID);
|
|
DecodeSingleHeader(strContentDisposition, RawHeaders, S);
|
|
if (S <> '') then
|
|
DecodeContentDisposition(S);
|
|
if (FContentDispositionType = strAttachment) then {!!.12}
|
|
Inc (FParent.FAttachmentCount); {!!.12}{!!.15}
|
|
end;
|
|
|
|
{ Compute attachment coding progress and fire OnCodingProgress event }
|
|
procedure TIpMimeEntity.DoOnCodingProgress(Count, TotalSize : Longint;
|
|
var Abort : Boolean);
|
|
{ IMPORTANT: The progress event must only be fired by the root parent }
|
|
begin
|
|
if (Parent = nil) or (Parent = Self) then begin
|
|
FProgress := ((Count*100) div TotalSize);
|
|
if (FProgress > 100) then
|
|
FProgress := 100;
|
|
if (FProgress div 10) = 0 then
|
|
PrevProgress := 0;
|
|
|
|
{ report progress in 10% increments }
|
|
if ((FProgress div 10) > (PrevProgress div 10)) then begin
|
|
PrevProgress := FProgress;
|
|
if Assigned(FOnCodingProgress) then
|
|
FOnCodingProgress(Self, FProgress, Abort);
|
|
end;
|
|
end else
|
|
Parent.DoOnCodingProgress(Count, TotalSize, Abort);
|
|
end;
|
|
|
|
{ Generate Mime message stream from properties (and nested Mime blocks) }
|
|
function TIpMimeEntity.EncodeEntity(OutStream : TIpAnsiTextStream) : string;
|
|
var
|
|
i : Integer;
|
|
S : string;
|
|
RawHeaders : TStringList;
|
|
Ch : AnsiChar;
|
|
begin
|
|
Result := FParentBoundary;
|
|
|
|
{ write out mime headers }
|
|
if (Result <> '') then begin
|
|
OutStream.WriteLine('--' + Result);
|
|
RawHeaders := TStringList.Create;
|
|
try
|
|
EncodeMimeHeaders(RawHeaders);
|
|
if (RawHeaders.Count > 0) then
|
|
for i := 0 to Pred(RawHeaders.Count) do
|
|
if (RawHeaders[i] <> '') then
|
|
OutStream.WriteLine(RawHeaders[i]);
|
|
OutStream.WriteLine('');
|
|
finally
|
|
RawHeaders.Free;
|
|
end;
|
|
end;
|
|
|
|
// flush to update underlaying memory streams
|
|
Body.Flush;
|
|
{ write out mime body }
|
|
if (Body.FastSize > 0) then
|
|
begin
|
|
// presize stream for more speed
|
|
OutStream.Stream.Size := OutStream.Stream.Size + Body.FastSize;
|
|
// use optimal method depending on the source stream to copy the stream
|
|
if Body.Stream is TIpMemMapStream then
|
|
OutStream.Write((Body.Stream as TIpMemMapStream).Memory^, Body.FastSize)
|
|
else
|
|
if Body.Stream is TMemoryStream then
|
|
OutStream.Write((Body.Stream as TMemoryStream).Memory^, Body.Stream.Size)
|
|
else
|
|
OutStream.CopyFrom(Body, 0); // copy the entire stream from the beginning
|
|
|
|
{ make sure the body is properly terminated } {!!.01}
|
|
OutStream.Position := OutStream.Size - 1; {!!.01}
|
|
TIpBufferedStream(OutStream).ReadChar(Ch); {!!.01}
|
|
if ((Ch <> #13) and (Ch <> #10)) then {!!.01}
|
|
OutStream.WriteLine(''); {!!.01}
|
|
end;
|
|
|
|
{ encode nested mime parts - recursively }
|
|
if (FMimeParts.Count > 0) then begin
|
|
for i := 0 to Pred(FMimeParts.Count) do
|
|
S := FMimeParts[i].EncodeEntity(OutStream);
|
|
OutStream.WriteLine('--' + S + '--');
|
|
end;
|
|
end;
|
|
|
|
{Begin !!.14}
|
|
function TIpMimeEntity.ContainsSpecialChars(const Value : string) : Boolean;
|
|
var
|
|
Inx : Integer;
|
|
begin
|
|
Result := False;
|
|
for Inx := 1 to Length(Value) do
|
|
if (Ord(Value[Inx]) <= 32) or
|
|
(Value[Inx] in ['(', ')', '<', '>', '@',
|
|
',', ';', ':', '\', '"',
|
|
'/', '[', ']', '?', '=']) then begin
|
|
Result := True;
|
|
Break;
|
|
end; { if }
|
|
end;
|
|
{End !!.14}
|
|
|
|
{ Generate Content-Disposition header into raw header list }
|
|
procedure TIpMimeEntity.EncodeContentDisposition(RawHeaders : TStringList);
|
|
var
|
|
Params : TStringList;
|
|
begin
|
|
if (FContentDispositionType = '') then
|
|
Exit;
|
|
|
|
Params := TStringList.Create;
|
|
try
|
|
Params.Add(FContentDispositionType);
|
|
{Begin !!.14}
|
|
if (FFileName <> '') then begin
|
|
{ If the filename contains spaces, control characters, or any of the
|
|
special characters identified in RFC 1521 then wrap the filename in
|
|
quotes.
|
|
|
|
Assumption: FFileName length is <= 78 characters. Future enhancement
|
|
is to support RFC 2184. }
|
|
if ContainsSpecialChars(FFileName) then
|
|
Params.Add(strFileName + '"' + FFileName + '"')
|
|
else
|
|
Params.Add(strFileName + FFileName);
|
|
end; { if }
|
|
{End !!.14}
|
|
if (FCreationDate <> '') then
|
|
Params.Add(strCreationDate + FCreationDate);
|
|
if (FModificationDate <> '') then
|
|
Params.Add(strModificationDate + FModificationDate);
|
|
if (FReadDate <> '') then
|
|
Params.Add(strReadDate + FReadDate);
|
|
if (FOriginalSize > 0) then
|
|
Params.Add(strSize + IntToStr(FOriginalSize));
|
|
EncodeListHeader(strContentDisposition, RawHeaders, Params, ';', False);
|
|
finally
|
|
Params.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Generate Content-Type header into raw header list }
|
|
procedure TIpMimeEntity.EncodeContentType(RawHeaders : TStringList);
|
|
var
|
|
S : string;
|
|
Params : TStringList;
|
|
begin
|
|
if (FContentType = '') then
|
|
Exit;
|
|
|
|
Params := TStringList.Create;
|
|
try
|
|
S := FContentType;
|
|
if (FContentSubType <> '') then
|
|
S := S + '/' + FContentSubType;
|
|
Params.Add(S);
|
|
if IsMultipart then
|
|
Params.Add(strBoundary + '"' + FBoundary + '"');
|
|
if (FEntityName <> '') then
|
|
Params.Add(strName + '"' + FEntityName + '"');
|
|
if (FCharacterSet <> '') then
|
|
Params.Add(strCharSet + FCharacterSet); {no quotes}
|
|
|
|
{!!.02}
|
|
{ encode multipart/related parameters }
|
|
if (FRelatedType <> '') then begin
|
|
if (FRelatedSubtype <> '') then
|
|
Params.Add(strType + '"' + FRelatedType + '/' + FRelatedSubtype + '"')
|
|
else
|
|
Params.Add(strType + '"' + FRelatedType + '"');
|
|
if (FRelatedStart <> '') then
|
|
Params.Add(strStart + '"' + FRelatedStart + '"');
|
|
if (FRelatedStartInfo <> '') then
|
|
Params.Add(strStartInfo + '"' + FRelatedStartInfo + '"');
|
|
end;
|
|
{!!.02}
|
|
|
|
EncodeListHeader(strContentType, RawHeaders, Params, ';', False);
|
|
finally
|
|
Params.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Generate Content-TranferEncoding header into raw header list }
|
|
procedure TIpMimeEntity.EncodeContentTransferEncoding(RawHeaders : TStringList);
|
|
begin
|
|
case FContentTransferEncoding of
|
|
em7bit : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, str7Bit);
|
|
em8bit : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, str8Bit);
|
|
emBase64 : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBase64);
|
|
emBinary : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBinary);
|
|
emBinHex : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBinHex);
|
|
emQuoted : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strQuoted);
|
|
emUUEncode : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strUUEncode);
|
|
end;
|
|
end;
|
|
|
|
{ Generate Mime headers into raw header list }
|
|
procedure TIpMimeEntity.EncodeMimeHeaders(RawHeaders : TStringList);
|
|
begin
|
|
if (FContentType <> '') then begin
|
|
EncodeSingleHeader(strMimeVersion, RawHeaders, FMimeVersion);
|
|
EncodeContentType(RawHeaders);
|
|
EncodeSingleHeader(strContentDescription, RawHeaders, FContentDescription);
|
|
EncodeSingleHeader(strContentID, RawHeaders, FContentID);
|
|
EncodeContentTransferEncoding(RawHeaders);
|
|
EncodeContentDisposition(RawHeaders);
|
|
end;
|
|
end;
|
|
|
|
{ Encode Mime body from TStream - file name is optional }
|
|
procedure TIpMimeEntity.EncodeBodyStream(InStream : TStream; const aFileName : string);
|
|
{Begin !!.12}
|
|
var
|
|
LargeAttachment : Boolean;
|
|
{ Large attachments are handled with memory map streams in order to avoid
|
|
whacko memory issues with TMemoryStream. }
|
|
begin
|
|
if (Instream.Size > 0) then begin
|
|
LargeAttachment := (InStream.Size > IpLgAttachSizeBoundry);
|
|
if LargeAttachment then
|
|
ClearBodyLargeAttach(InStream.Size)
|
|
else
|
|
begin
|
|
ClearBody;
|
|
// presize stream for more speed
|
|
FBody.Stream.Size := Trunc(InStream.Size * 1.3695);
|
|
end;
|
|
{End !!.12}
|
|
case FContentTransferEncoding of
|
|
em7Bit : Encode8Bit(InStream);
|
|
em8Bit : Encode8Bit(InStream);
|
|
emBase64 : EncodeBase64(InStream);
|
|
emBinary : Encode8Bit(InStream);
|
|
emBinHex : EncodeBinHex(InStream, aFileName);
|
|
emQuoted : EncodeQuoted(InStream);
|
|
emUUEncode : EncodeUUEncode(InStream, aFileName);
|
|
emUnknown : Encode8Bit(InStream);
|
|
end;
|
|
{Begin !!.12}
|
|
FBody.Flush;
|
|
if LargeAttachment then
|
|
{ This is a large attachment that was written to a memory map stream.
|
|
Memory map streams are usually created larger than necessary so shrink
|
|
it down to the correct size. }
|
|
TIpMemMapStream(FBody.Stream).Size := TIpMemMapStream(FBody.Stream).DataSize;
|
|
{End !!.12}
|
|
end;
|
|
FOriginalSize := InStream.Size;
|
|
FFileName := ExtractFileName(aFileName);
|
|
end;
|
|
|
|
{ Encode Mime body from TStrings - file name is optional }
|
|
procedure TIpMimeEntity.EncodeBodyStrings(InStrings : TStrings; const aFileName : string);
|
|
var
|
|
MS : TMemoryStream;
|
|
begin
|
|
if (InStrings.Count > 0) then begin
|
|
MS := TMemoryStream.Create;
|
|
try
|
|
InStrings.SaveToStream(MS);
|
|
MS.Position := 0; {!!.03}
|
|
FOriginalSize := MS.Size;
|
|
FFileName := ExtractFileName(aFileName);
|
|
EncodeBodyStream(MS, aFileName);
|
|
finally
|
|
MS.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Encode Mime body from file }
|
|
procedure TIpMimeEntity.EncodeBodyFile(const InFile : string);
|
|
var
|
|
FS : TIpMemMapStream; {!!.12}
|
|
i : Integer;
|
|
aExt, aTyp, aSub : string;
|
|
aEnc : TIpMimeEncodingMethod;
|
|
begin
|
|
{ If content-type, has not been defined for this entity, }
|
|
{ default values for that file extension will be used. }
|
|
{ These values are defined in the include file, IPDEFCT.INC }
|
|
aTyp := strApplication;
|
|
aSub := strOctetStream;
|
|
aEnc := emBase64;
|
|
aExt := ExtractFileExt(InFile);
|
|
for i := 0 to High(DefExtensions) do
|
|
if (aExt = DefExtensions[i]) then begin
|
|
aTyp := DefContent[i].Typ;
|
|
aSub := DefContent[i].Sub;
|
|
aEnc := DefContent[i].Enc;
|
|
Break;
|
|
end;
|
|
if (FContentType = '') then begin
|
|
FContentType := aTyp;
|
|
FContentSubtype := aSub;
|
|
FContentTransferEncoding := aEnc;
|
|
end;
|
|
if (FContentTransferEncoding = emUnknown) then
|
|
FContentTransferEncoding := aEnc;
|
|
|
|
FS := TIpMemMapStream.Create(InFile, True, False); {!!.12}
|
|
try
|
|
FS.Open; {!!.12}
|
|
FOriginalSize := FS.Size;
|
|
FFileName := ExtractFileName(InFile);
|
|
EncodeBodyStream(FS, FFileName);
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Decode encoded Mime block body to TStream }
|
|
procedure TIpMimeEntity.ExtractBodyStream(OutStream : TStream);
|
|
var
|
|
MS : TMemoryStream;
|
|
begin
|
|
if (FBody.Size > 0) then begin
|
|
{ We want to append the decoded data to the end of OutStream, }
|
|
{ so a local memory stream is used since OutStream may be a }
|
|
{ TIpAnsiTextStream, in which case the decoding algorithms }
|
|
{ will overwrite its existing contents. }
|
|
MS := TMemoryStream.Create;
|
|
try
|
|
case FContentTransferEncoding of
|
|
em7Bit : Decode8Bit(MS);
|
|
em8Bit : Decode8Bit(MS);
|
|
emBase64 : DecodeBase64(MS);
|
|
emBinary : OutStream.CopyFrom(FBody, FBody.Size); {!!.14}
|
|
emBinHex : DecodeBinHex(MS);
|
|
emQuoted : DecodeQuoted(MS);
|
|
emUUEncode : DecodeUUEncode(MS);
|
|
emUnknown : Decode8Bit(MS);
|
|
end;
|
|
OutStream.CopyFrom(MS, 0);
|
|
finally
|
|
MS.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Decode encoded Mime block body to TStrings }
|
|
procedure TIpMimeEntity.ExtractBodyStrings(OutStrings : TStrings);
|
|
var
|
|
MS : TMemoryStream;
|
|
begin
|
|
if (FBody.Size > 0) then begin
|
|
MS := TMemoryStream.Create;
|
|
try
|
|
ExtractBodyStream(MS);
|
|
MS.Position := 0;
|
|
OutStrings.LoadFromStream(MS);
|
|
finally
|
|
MS.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Decode encoded Mime block body to file }
|
|
procedure TIpMimeEntity.ExtractBodyFile(const OutFile : string);
|
|
var
|
|
FS : TFileStream;
|
|
begin
|
|
if (FBody.Size > 0) then begin
|
|
FS := TFileStream.Create(UTF8ToSys(OutFile), fmCreate);
|
|
try
|
|
ExtractBodyStream(FS);
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Access/create specified MIME part }
|
|
function TIpMimeEntity.GetMimePart(const aType, aSubType, aContentID : string;
|
|
CanCreate : Boolean) : TIpMimeEntity;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
Result := nil;
|
|
if (MimeParts.Count > 0) then
|
|
for i := 0 to Pred(MimeParts.Count) do
|
|
{ ContentID is primary search key }
|
|
if (aContentID <> '') then begin
|
|
if (MimeParts[i].ContentID = aContentID) then begin
|
|
Result := MimeParts[i];
|
|
Break;
|
|
end;
|
|
end else begin
|
|
if (MimeParts[i].ContentType = aType) and
|
|
(MimeParts[i].ContentSubtype = aSubType) then begin
|
|
Result := MimeParts[i];
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
if Assigned(Result) then
|
|
Result.Body.Position := 0
|
|
else if CanCreate then begin
|
|
Result := NewMimePart;
|
|
Result.ContentType := aType;
|
|
Result.ContentSubtype := aSubtype;
|
|
Result.ContentID := aContentID;
|
|
end;
|
|
end;
|
|
|
|
{!!.02}
|
|
{ Search all nested levels for specified MIME part }
|
|
function TIpMimeEntity.FindNestedMimePart(const aType, aSubType, aContentID : string) : TIpMimeEntity;
|
|
var
|
|
i : Integer;
|
|
Blk : TIpMimeEntity;
|
|
begin
|
|
Result := nil;
|
|
if (MimeParts.Count > 0) then
|
|
for i := 0 to Pred(MimeParts.Count) do begin
|
|
{ ContentID is primary search key }
|
|
if (aContentID <> '') and {!!.12}
|
|
(IsSameString (MimeParts[i].ContentID, {!!.12}
|
|
aContentID, False)) then begin {!!.12}
|
|
Result := MimeParts[i];
|
|
Break;
|
|
end else if (IsSameString (MimeParts[i].ContentType, {!!.12}
|
|
aType, False)) and {!!.12}
|
|
(IsSameString (MimeParts[i].ContentSubtype, {!!.12}
|
|
aSubType, False)) then begin {!!.12}
|
|
Result := MimeParts[i];
|
|
Break;
|
|
end else begin
|
|
Blk := MimeParts[i];
|
|
Result := Blk.FindNestedMimePart(aType, aSubType, aContentID);
|
|
if Assigned(Result) then
|
|
Break;
|
|
end;
|
|
end;
|
|
if Assigned(Result) then
|
|
Result.Body.Position := 0;
|
|
end;
|
|
|
|
{ Create nested Mime block and add to list }
|
|
function TIpMimeEntity.NewMimePart : TIpMimeEntity;
|
|
begin
|
|
{parent Entity is now multipart}
|
|
FIsMime := True;
|
|
FIsMultipart := True;
|
|
FContentType := strMultipart;
|
|
if (FBoundary = '') then
|
|
FBoundary := GenerateBoundary;
|
|
|
|
Result := TIpMimeEntity.Create(Self);
|
|
FMimeParts.Add(Result);
|
|
end;
|
|
|
|
{ Copy Instream to OutStream as is - no decoding }
|
|
procedure TIpMimeEntity.Decode8Bit(OutStream : TStream);
|
|
var
|
|
FS : TIpAnsiTextStream;
|
|
Abort : Boolean;
|
|
begin
|
|
Abort := False;
|
|
FS := TIpAnsiTextStream.Create(OutStream);
|
|
try
|
|
FBody.Position := 0;
|
|
while (FBody.Position < FBody.Size) and not Abort do begin
|
|
FS.WriteLine(FBody.ReadLine);
|
|
DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
|
|
end;
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Decode InStream to OutStream - Base64 }
|
|
procedure TIpMimeEntity.DecodeBase64(OutStream : TStream);
|
|
{ rewritten } {!!.12}
|
|
var
|
|
I : Integer; {!!.16}
|
|
C : Char;
|
|
InBuf : array[0..3] of Char;
|
|
OutBuf : array[0..2] of Byte;
|
|
Done : Boolean;
|
|
Abort : Boolean;
|
|
BufStream : TIpBufferedStream;
|
|
begin
|
|
BufStream := (FBody as TIpBufferedStream);
|
|
BufStream.Position := 0;
|
|
Done := False;
|
|
Abort := False;
|
|
|
|
while not (Done or Abort) do begin
|
|
{ read in the next 4 valid Base64 characters }
|
|
I := 0;
|
|
InBuf := '===='; {!!.15}
|
|
while (I < 4) do begin
|
|
if not BufStream.ReadChar(C) then begin
|
|
Done := True;
|
|
Break;
|
|
end;
|
|
|
|
{ skip bad characters }
|
|
if (Low(IpD64Table) <= C) and (C <= High(IpD64Table)) then
|
|
if (IpD64Table[C] <> $7F) then begin
|
|
InBuf[I] := C;
|
|
Inc(I);
|
|
end;
|
|
end;
|
|
|
|
{ Decode 4 characters to 3 bytes }
|
|
I := 0;
|
|
OutBuf[0] := ((IpD64Table[InBuf[0]] shl 2) or (IpD64Table[InBuf[1]] shr 4));
|
|
Inc(I);
|
|
if InBuf[2] <> '=' then begin
|
|
OutBuf[1] := ((IpD64Table[InBuf[1]] shl 4) or (IpD64Table[InBuf[2]] shr 2));
|
|
Inc(I);
|
|
if InBuf[3] <> '=' then begin
|
|
OutBuf[2] := ((IpD64Table[InBuf[2]] shl 6) or IpD64Table[InBuf[3]]);
|
|
Inc(I);
|
|
end else
|
|
Done := True;
|
|
end else
|
|
Done := True;
|
|
OutStream.Write(OutBuf, I);
|
|
DoOnCodingProgress(OutStream.Position, BufStream.FastSize, Abort); {!!.16}
|
|
end;
|
|
end;
|
|
|
|
{ Decode InStream to OutStream - BinHex }
|
|
procedure TIpMimeEntity.DecodeBinHex(OutStream : TStream);
|
|
var
|
|
InBuf : array[1..4] of Byte;
|
|
OutBuf : array[1..3] of Byte;
|
|
i : Byte;
|
|
btThis, btLast, btNext : Byte;
|
|
ch : AnsiChar;
|
|
// headerlength is encoded as byte, HeaderFileName can only 256 bytes long
|
|
HeaderFileName : Array [0..MaxByte] of Byte; {!!.12}{!!.16}
|
|
HeaderLength : byte; {!!.12}
|
|
CRC : Word;
|
|
DataOffset, DataEnd, HeaderEnd : Longint;
|
|
WS1, WS2 : TMemoryStream;
|
|
Header : BinHexHeader;
|
|
Abort : Boolean;
|
|
BufStream : TIpBufferedStream;
|
|
|
|
function NextChar : AnsiChar;
|
|
{- skip past any CRLF's and return the next message stream char }
|
|
var
|
|
c : AnsiChar;
|
|
begin
|
|
c := #0;
|
|
repeat
|
|
BufStream.ReadChar(c);
|
|
until ((c <> #13) and (c <> #10)) or (BufStream.Position = BufStream.Size);
|
|
Result := c;
|
|
end;
|
|
|
|
function ValidChar(ch : AnsiChar) : Boolean;
|
|
{- test if ch is a valid BinHex encoded char }
|
|
var
|
|
b : Byte;
|
|
begin
|
|
Result := False;
|
|
b := Ord(ch);
|
|
if (b > 32) and (b < 115) then
|
|
if IpHexBinTable[b] <> $0FF then
|
|
Result := True;
|
|
end;
|
|
|
|
begin
|
|
Abort := False;
|
|
FBody.Position := 0;
|
|
if Pos('(This file must be converted with BinHex', FBody.ReadLine) = 0 then
|
|
raise EIpBaseException.Create(SBinHexBadFormat);
|
|
if (NextChar <> ':') then
|
|
raise EIpBaseException.Create(SBinHexColonExpected);
|
|
|
|
{ decode attachment into working stream }
|
|
BufStream := (FBody as TIpBufferedStream);
|
|
WS1 := TMemoryStream.Create;
|
|
try
|
|
i := 0;
|
|
ch := NextChar;
|
|
while (ch <> ':') and (BufStream.Position < BufStream.Size) and not Abort do begin
|
|
if not ValidChar(ch) then
|
|
raise EIpBaseException.Create(SBinHexBadChar);
|
|
Inc(i);
|
|
InBuf[i] := IpHexBinTable[Ord(ch)];
|
|
{ decode 4 characters into 3 bytes }
|
|
if (i = 4) then begin
|
|
i := 0;
|
|
{ 1st : upper 6 lower 2 }
|
|
OutBuf[1] := (InBuf[1] shl 2) or ((InBuf[2] shr 4) and $03);
|
|
{ 2nd : upper 4 lower 4 }
|
|
OutBuf[2] := (InBuf[2] shl 4) or ((InBuf[3] shr 2) and $0F);
|
|
{ 3rd : upper 2 lower 6 }
|
|
OutBuf[3] := (InBuf[3] shl 6) or (InBuf[4] and $03F);
|
|
WS1.Write(OutBuf, SizeOf(OutBuf));
|
|
end;
|
|
ch := NextChar;
|
|
end;
|
|
|
|
{ handle odd characters }
|
|
if (i > 0) then begin
|
|
if (i = 1) then
|
|
raise EIpBaseException.Create(SBinHexOddChar);
|
|
OutBuf[1] := (InBuf[1] shl 2) or ((InBuf[2] shr 4) and $03);
|
|
if (i = 2) then
|
|
WS1.Write(OutBuf, 1)
|
|
else begin
|
|
OutBuf[2] := (InBuf[2] shl 4) or ((InBuf[3] shr 2) and $0F);
|
|
WS1.Write(OutBuf, 2);
|
|
end;
|
|
DoOnCodingProgress(BufStream.Position, BufStream.Size, Abort);
|
|
end;
|
|
if Abort then
|
|
Exit;
|
|
|
|
{ should be the end of file marker }
|
|
if (ch <> ':') then
|
|
raise EIpBaseException.Create(SBinHexColonExpected);
|
|
|
|
{ expand RLE sequences }
|
|
WS2 := TMemoryStream.Create;
|
|
try
|
|
WS1.Position := 0;
|
|
btThis := 0;
|
|
while (WS1.Position < WS1.Size) and not Abort do begin
|
|
btLast := btThis;
|
|
WS1.Read(btThis, 1);
|
|
if (btThis <> RLEChar) then
|
|
WS2.Write(btThis, 1)
|
|
else begin
|
|
WS1.Read(btNext, 1);
|
|
if (btNext = 0) then
|
|
WS2.Write(btThis, 1)
|
|
else begin
|
|
btThis := btLast;
|
|
for i := 1 to (btNext - 1) do
|
|
WS2.Write(btThis, 1);
|
|
end;
|
|
end;
|
|
DoOnCodingProgress(WS1.Position, WS1.Size, Abort);
|
|
end;
|
|
if Abort then
|
|
WS2.Free;
|
|
|
|
{ strip off header }
|
|
FillChar (HeaderFileName, SizeOf (HeaderFileName), $00); {!!.12}
|
|
FillChar(Header, SizeOf(Header), #0);
|
|
WS2.Position := 0;
|
|
WS2.Read(HeaderLength, SizeOf (Byte)); {!!.12}
|
|
WS2.Read(HeaderFileName, HeaderLength); {!!.12}
|
|
WS2.Read(Header, SizeOf(Header));
|
|
|
|
{ check header CRC }
|
|
HeaderEnd := WS2.Position;
|
|
WS2.Read(CRC, 2);
|
|
DataOffset := WS2.Position;
|
|
if (CRC <> BinHexCRC(WS2, 0, HeaderEnd)) then
|
|
raise EIpBaseException.Create(SBinHexBadHeaderCRC);
|
|
DataEnd := DataOffset + htonl(Header.DFLong);
|
|
if (DataEnd > WS2.Size) then
|
|
raise EIpBaseException.Create(SBinHexLengthErr);
|
|
if (htonl(Header.RFLong) > 0) then
|
|
raise EIpBaseException.Create(SBinHexResourceForkErr);
|
|
|
|
{ check data fork CRC - follows data fork }
|
|
WS2.Position := DataEnd;
|
|
WS2.Read(CRC, 2);
|
|
if (CRC <> BinHexCRC(WS2, DataOffset, DataEnd)) then
|
|
raise EIpBaseException.Create(SBinHexBadDataCRC);
|
|
|
|
{ copy data fork to OutStream }
|
|
WS2.Position := DataOffset;
|
|
OutStream.CopyFrom(WS2, DataEnd - DataOffset);
|
|
finally
|
|
WS2.Free;
|
|
end;
|
|
finally
|
|
WS1.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Decode InStream to OutStream - QuotedPrintable }
|
|
procedure TIpMimeEntity.DecodeQuoted(OutStream : TStream);
|
|
var
|
|
O, Count, WS : Byte; {!!.12}
|
|
I : integer; {!!.12}
|
|
InBuf : array[0..pred (MaxLine)] of Byte; {!!.15}
|
|
OutBuf : array[0..pred (MaxLine)] of Byte; {!!.15}
|
|
Decoding : Boolean;
|
|
Keeper : Boolean;
|
|
Abort : Boolean;
|
|
BufStream : TIpBufferedStream;
|
|
begin
|
|
Abort := False;
|
|
FBody.Position := 0;
|
|
BufStream := FBody as TIpBufferedStream;
|
|
FillChar(InBuf, SizeOf(InBuf), #0);
|
|
WS := $FF;
|
|
Decoding := True;
|
|
Keeper := False;
|
|
|
|
{ Skip any CR/LF's to get to the encoded stuff }
|
|
while True do begin
|
|
if not BufStream.ReadChar(Char(InBuf[0])) then
|
|
Exit;
|
|
if ((InBuf[0] <> $0D) and (InBuf[0] <> $0A)) then begin
|
|
Keeper := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
while Decoding and not Abort do begin
|
|
{ Initialize }
|
|
if Keeper then begin
|
|
I := 1;
|
|
Keeper := False;
|
|
end else begin
|
|
I := 0;
|
|
end;
|
|
O := 0;
|
|
|
|
{ Read in one line at a time - skipping over bad characters }
|
|
while True do begin
|
|
if (I > High(InBuf)) then {!!.01}
|
|
raise EIpBaseException.Create(SLineLengthErr); {!!.01}
|
|
if not BufStream.ReadChar(Char(InBuf[I])) then
|
|
Break;
|
|
case InBuf[I] of
|
|
$0A : Continue;
|
|
$0D : begin
|
|
Inc(I);
|
|
Break;
|
|
end;
|
|
{ Test for potential end of data }
|
|
{ '--' is probably the next Mime boundary }
|
|
{ $2D : if (I = 1) and (InBuf[0] = $2D) then Exit;} {!!.03}
|
|
end;
|
|
Inc(I);
|
|
end;
|
|
|
|
if I = 0 then Exit;
|
|
Count := I;
|
|
I := 0;
|
|
|
|
{ Decode data to output stream }
|
|
while I < Count do begin
|
|
case InBuf[I] of
|
|
9 : begin
|
|
if WS = $FF then
|
|
WS := O;
|
|
OutBuf[O] := InBuf[I];
|
|
Inc(O);
|
|
Inc(I);
|
|
end;
|
|
13 : if WS = $FF then begin
|
|
OutBuf[O] := 13;
|
|
OutBuf[O+1] := 10;
|
|
Inc(O, 2);
|
|
Inc(I);
|
|
end else begin
|
|
OutBuf[WS] := 13;
|
|
OutBuf[WS+1] := 10;
|
|
O := WS+2;
|
|
Inc(I);
|
|
end;
|
|
32 : begin
|
|
if WS = $FF then
|
|
WS := O;
|
|
OutBuf[O] := InBuf[I];
|
|
Inc(O);
|
|
Inc(I);
|
|
end;
|
|
33..60 : begin
|
|
WS := $FF;
|
|
OutBuf[O] := InBuf[I];
|
|
Inc(O);
|
|
Inc(I);
|
|
end;
|
|
61 : begin
|
|
WS := $FF;
|
|
if I+2 >= Count then Break;
|
|
case InBuf[I+1] of
|
|
48 : OutBuf[O] := 0; {0}
|
|
49 : OutBuf[O] := 16; {1}
|
|
50 : OutBuf[O] := 32; {2}
|
|
51 : OutBuf[O] := 48; {3}
|
|
52 : OutBuf[O] := 64; {4}
|
|
53 : OutBuf[O] := 80; {5}
|
|
54 : OutBuf[O] := 96; {6}
|
|
55 : OutBuf[O] := 112; {7}
|
|
56 : OutBuf[O] := 128; {8}
|
|
57 : OutBuf[O] := 144; {9}
|
|
65 : OutBuf[O] := 160; {A}
|
|
66 : OutBuf[O] := 176; {B}
|
|
67 : OutBuf[O] := 192; {C}
|
|
68 : OutBuf[O] := 208; {D}
|
|
69 : OutBuf[O] := 224; {E}
|
|
70 : OutBuf[O] := 240; {F}
|
|
97 : OutBuf[O] := 160; {a}
|
|
98 : OutBuf[O] := 176; {b}
|
|
99 : OutBuf[O] := 192; {c}
|
|
100 : OutBuf[O] := 208; {d}
|
|
101 : OutBuf[O] := 224; {e}
|
|
102 : OutBuf[O] := 240; {f}
|
|
end;
|
|
case InBuf[I+2] of
|
|
48 : ; {0}
|
|
49 : OutBuf[O] := OutBuf[O] + 1; {1}
|
|
50 : OutBuf[O] := OutBuf[O] + 2; {2}
|
|
51 : OutBuf[O] := OutBuf[O] + 3; {3}
|
|
52 : OutBuf[O] := OutBuf[O] + 4; {4}
|
|
53 : OutBuf[O] := OutBuf[O] + 5; {5}
|
|
54 : OutBuf[O] := OutBuf[O] + 6; {6}
|
|
55 : OutBuf[O] := OutBuf[O] + 7; {7}
|
|
56 : OutBuf[O] := OutBuf[O] + 8; {8}
|
|
57 : OutBuf[O] := OutBuf[O] + 9; {9}
|
|
65 : OutBuf[O] := OutBuf[O] + 10; {A}
|
|
66 : OutBuf[O] := OutBuf[O] + 11; {B}
|
|
67 : OutBuf[O] := OutBuf[O] + 12; {C}
|
|
68 : OutBuf[O] := OutBuf[O] + 13; {D}
|
|
69 : OutBuf[O] := OutBuf[O] + 14; {E}
|
|
70 : OutBuf[O] := OutBuf[O] + 15; {F}
|
|
97 : OutBuf[O] := OutBuf[O] + 10; {a}
|
|
98 : OutBuf[O] := OutBuf[O] + 11; {b}
|
|
99 : OutBuf[O] := OutBuf[O] + 12; {c}
|
|
100 : OutBuf[O] := OutBuf[O] + 13; {d}
|
|
101 : OutBuf[O] := OutBuf[O] + 14; {e}
|
|
102 : OutBuf[O] := OutBuf[O] + 15; {f}
|
|
end;
|
|
Inc(I, 3);
|
|
Inc(O);
|
|
end;
|
|
62..126 : begin
|
|
WS := $FF;
|
|
OutBuf[O] := InBuf[I];
|
|
Inc(O);
|
|
Inc(I);
|
|
end;
|
|
else
|
|
Inc(I);
|
|
end;
|
|
end;
|
|
|
|
if O>0 then
|
|
OutStream.Write(OutBuf, O)
|
|
else
|
|
Break; { OutBuf is empty }
|
|
DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
|
|
end;
|
|
end;
|
|
|
|
{ Decode InStream to OutStream - UUEncode }
|
|
procedure TIpMimeEntity.DecodeUUEncode(OutStream : TStream);
|
|
var
|
|
I, O, Len, Count : Byte;
|
|
InBuf : array[0..85] of Byte;
|
|
OutBuf : array[0..65] of Byte;
|
|
FirstLine : Boolean;
|
|
Abort : Boolean;
|
|
BufStream : TIpBufferedStream;
|
|
begin
|
|
Abort := False;
|
|
FBody.Position := 0;
|
|
BufStream := FBody as TIpBufferedStream;
|
|
FirstLine := True;
|
|
while True and not Abort do begin
|
|
{ Initialize }
|
|
I := 0;
|
|
O := 0;
|
|
|
|
{ Skip any CR/LF's to get to the encoded stuff }
|
|
while True do begin
|
|
if not BufStream.ReadChar(Char(InBuf[0])) then
|
|
Exit;
|
|
if FirstLine then begin
|
|
if ((InBuf[0] <> $0D) and (InBuf[0] <> $0A)) then begin
|
|
FirstLine := False;
|
|
Break;
|
|
end;
|
|
end else begin
|
|
if ((InBuf[0] = $0D) or (InBuf[0] = $0A)) then FirstLine := True;
|
|
end;
|
|
end;
|
|
|
|
{ We're done }
|
|
if AnsiChar(InBuf[0]) = '`' then Exit;
|
|
|
|
{ Get count for this line }
|
|
Len := (((InBuf[0] - $20) and $3F) * 4) div 3;
|
|
if (((InBuf[0] - $20) and $3F) * 4) mod 3 <> 0 then
|
|
Inc(Len);
|
|
|
|
Count := FBody.Read(InBuf, Len);
|
|
|
|
{ Unexpected situation }
|
|
if (Count <> Len) or (Count > 63) then
|
|
raise EIpBaseException.Create(SUUEncodeCountErr);
|
|
|
|
{ Decode buffer }
|
|
while (I < Count) do begin
|
|
if ((Count - I) >= 4) then begin
|
|
OutBuf[O] := (((InBuf[I] - $20) and $3F) shl 2) or
|
|
(((InBuf[I+1] - $20) and $3F) shr 4);
|
|
OutBuf[O+1] := (((InBuf[I+1] - $20) and $3F) shl 4) or
|
|
(((InBuf[I+2] - $20) and $3F) shr 2);
|
|
OutBuf[O+2] := (((InBuf[I+2] - $20) and $3F) shl 6) or
|
|
(((InBuf[I+3] - $20) and $3F));
|
|
Inc(O, 3);
|
|
end else begin
|
|
if (Count >= 2) then begin
|
|
OutBuf[O] := (((InBuf[I] - $20) and $3F) shl 2) or
|
|
(((InBuf[I+1] - $20) and $3F) shr 4);
|
|
Inc(O);
|
|
end;
|
|
if (Count >= 3) then begin
|
|
OutBuf[O+1] := (((InBuf[I+1] - $20) and $3F) shl 4) or
|
|
(((InBuf[I+2] - $20) and $3F) shr 2);
|
|
Inc(O);
|
|
end;
|
|
end;
|
|
Inc(I, 4);
|
|
end;
|
|
OutStream.Write(OutBuf, O);
|
|
DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
|
|
end;
|
|
end;
|
|
|
|
{ Encode InStream to OutStream - as is, no encoding }
|
|
procedure TIpMimeEntity.Encode8Bit(InStream : TStream);
|
|
var
|
|
FS : TIpAnsiTextStream;
|
|
Abort : Boolean;
|
|
begin
|
|
Abort := False;
|
|
FS := TIpAnsiTextStream.Create(InStream);
|
|
try
|
|
while not (FS.AtEndOfStream or Abort) do begin
|
|
FBody.WriteLine(FS.ReadLine);
|
|
DoOnCodingProgress(FS.Position, FS.Size, Abort);
|
|
end;
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Encode InStream to OutStream - Base64 }
|
|
procedure TIpMimeEntity.EncodeBase64(InStream : TStream);
|
|
begin
|
|
OctetStreamToHextetStream(InStream, FBody, Ip64Table, '=', #0);
|
|
end;
|
|
|
|
{ Encode InStream to OutStream - BinHex }
|
|
procedure TIpMimeEntity.EncodeBinHex(InStream : TStream;
|
|
const aFileName : string);
|
|
var
|
|
HeaderFileName : string; {!!.12}
|
|
CRC : Word;
|
|
DataOffset : DWord;
|
|
PrevByte, CurrByte, i : Byte;
|
|
Header : BinHexHeader;
|
|
WS1, WS2 : TMemoryStream;
|
|
Abort : Boolean;
|
|
|
|
begin
|
|
Abort := False;
|
|
WS1 := TMemoryStream.Create;
|
|
try
|
|
{ start with file name }
|
|
if (Length(aFileName) < MaxLine) then
|
|
HeaderFileName := UpperCase(ExtractFileName(aFileName))
|
|
else
|
|
HeaderFileName := Copy(UpperCase(ExtractFileName(aFileName)), 1, MaxLine);
|
|
WS1.Write(HeaderFileName, Length(HeaderFileName) + 1);
|
|
|
|
{ build rest of file header and header CRC and add to working stream }
|
|
FillChar(Header, SizeOf(Header), #0);
|
|
Move(BinHexFileType, Header.FileType, SizeOf(Header.FileType));
|
|
Move(BinHexFileType, Header.Creator, SizeOf(Header.Creator));
|
|
Header.DFLong := htonl(InStream.Size);
|
|
Header.RFLong := 0;
|
|
WS1.Write(Header, SizeOf(Header));
|
|
CRC := BinHexCRC(WS1, 0, WS1.Size);
|
|
WS1.Write(CRC, 2);
|
|
|
|
{ append data fork and data CRC to working stream }
|
|
DataOffset := WS1.Position;
|
|
InStream.Position := 0;
|
|
WS1.CopyFrom(InStream, InStream.Size);
|
|
CRC := BinHexCRC(WS1, DataOffset, WS1.Size);
|
|
WS1.Write(CRC, 2);
|
|
|
|
{ tack on resource fork CRC - not used but still required }
|
|
CRC := 0;
|
|
WS1.Write(CRC, 2);
|
|
|
|
{ go back and compress RLE sequences }
|
|
WS2 := TMemoryStream.Create;
|
|
try
|
|
WS1.Position := 0;
|
|
CurrByte := 0;
|
|
while (WS1.Position < WS1.Size) and not Abort do begin
|
|
PrevByte := CurrByte;
|
|
WS1.Read(CurrByte, 1);
|
|
if (CurrByte <> PrevByte) then
|
|
WS2.Write(CurrByte, 1)
|
|
else begin
|
|
i := 1;
|
|
repeat
|
|
i := i + WS1.Read(CurrByte, 1);
|
|
until (CurrByte <> PrevByte) or (i = 255) or
|
|
(WS1.Position = WS1.Size);
|
|
if (i > 2) then begin
|
|
WS2.Write(RLEChar, 1);
|
|
WS2.Write(i, 1);
|
|
WS2.Write(CurrByte, 1);
|
|
end else begin
|
|
WS2.Write(PrevByte, 1);
|
|
WS2.Write(CurrByte, 1);
|
|
end;
|
|
end;
|
|
DoOnCodingProgress(WS1.Position, WS1.Size, Abort);
|
|
end;
|
|
if Abort then
|
|
Exit;
|
|
|
|
{ write out preamble }
|
|
FBody.WriteLine('(This file must be converted with BinHex 4.0)');
|
|
|
|
{ Encode compressed stream and stream it out }
|
|
WS2.Position := 0;
|
|
OctetStreamToHextetStream(WS2, FBody, IpBinHexTable, #0, ':');
|
|
finally
|
|
WS2.Free;
|
|
end;
|
|
finally
|
|
WS1.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Encode InStream to OutStream - QuotedPrintable }
|
|
procedure TIpMimeEntity.EncodeQuoted(InStream : TStream);
|
|
var
|
|
O, W : Integer;
|
|
WordBuf, OutBuf : array[0..80] of AnsiChar;
|
|
CurChar : AnsiChar;
|
|
Abort : Boolean;
|
|
ByteStream : TIpByteStream;
|
|
|
|
procedure SendLine;
|
|
begin
|
|
if (OutBuf[O-1] = #9) or (OutBuf[O-1] = #32) then begin
|
|
OutBuf[O] := '=';
|
|
Inc(O);
|
|
end;
|
|
FBody.WriteLineZ(OutBuf);
|
|
FillChar(OutBuf, SizeOf(OutBuf), #0);
|
|
O := 0;
|
|
end;
|
|
|
|
procedure AddWordToOutBuf;
|
|
var
|
|
J : Integer;
|
|
begin
|
|
if (O + W) > 74 then SendLine;
|
|
for J := 0 to (W - 1) do begin
|
|
OutBuf[O] := WordBuf[J];
|
|
Inc(O);
|
|
end;
|
|
W := 0;
|
|
end;
|
|
|
|
procedure AddHexToWord(B : Byte);
|
|
begin
|
|
if W > 73 then AddWordToOutBuf;
|
|
WordBuf[W] := '=';
|
|
WordBuf[W+1] := HexDigits[B shr 4];
|
|
WordBuf[W+2] := HexDigits[B and $F];
|
|
Inc(W, 3)
|
|
end;
|
|
|
|
begin
|
|
Abort := False;
|
|
O := 0;
|
|
W := 0;
|
|
FillChar(OutBuf, SizeOf(OutBuf), #0);
|
|
ByteStream := TIpByteStream.Create(InStream);
|
|
try
|
|
while ByteStream.Read(Byte(CurChar)) and not Abort do begin
|
|
if (Ord(CurChar) in [33..60, 62..126]) then begin
|
|
WordBuf[W] := CurChar;
|
|
Inc(W);
|
|
if W > 74 then AddWordToOutBuf;
|
|
end else if (CurChar = ' ') or (CurChar = #9) then begin
|
|
WordBuf[W] := CurChar;
|
|
Inc(W);
|
|
AddWordToOutBuf;
|
|
end else if (CurChar = #13) then begin
|
|
AddWordToOutBuf;
|
|
SendLine;
|
|
end else if (CurChar = #10) then begin
|
|
{ Do nothing }
|
|
end else begin
|
|
AddHexToWord(Byte(CurChar));
|
|
end;
|
|
DoOnCodingProgress(ByteStream.Position, ByteStream.Size, Abort);
|
|
end;
|
|
finally
|
|
ByteStream.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Encode InStream to OutStream - UUEncode }
|
|
procedure TIpMimeEntity.EncodeUUEncode(InStream : TStream;
|
|
const aFileName : string);
|
|
var
|
|
I, O, Count, Temp : Byte;
|
|
InBuf : array[1..45] of Byte;
|
|
OutBuf : array[0..63] of AnsiChar;
|
|
Abort : Boolean;
|
|
begin
|
|
Abort := False;
|
|
FBody.WriteLine('begin 600 ' + aFileName);
|
|
|
|
{ Encode and stream the attachment }
|
|
repeat
|
|
Count := InStream.Read(InBuf, SizeOf(InBuf));
|
|
if Count <= 0 then Break;
|
|
I := 1;
|
|
O := 0;
|
|
OutBuf[O] := AnsiChar(IpUUTable[Count and $3F]);
|
|
Inc(O);
|
|
while I+2 <= Count do begin
|
|
{ Encode 1st byte }
|
|
Temp := (InBuf[I] shr 2);
|
|
OutBuf[O] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
|
|
{ Encode 1st/2nd byte }
|
|
Temp := (InBuf[I] shl 4) or (InBuf[I+1] shr 4);
|
|
OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
|
|
{ Encode 2nd/3rd byte }
|
|
Temp := (InBuf[I+1] shl 2) or (InBuf[I+2] shr 6);
|
|
OutBuf[O+2] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
|
|
{ Encode 3rd byte }
|
|
Temp := (InBuf[I+2] and $3F);
|
|
OutBuf[O+3] := AnsiChar(IpUUTable[Temp]);
|
|
|
|
Inc(I, 3);
|
|
Inc(O, 4);
|
|
end;
|
|
|
|
{ Are there odd bytes to add? }
|
|
if (I <= Count) then begin
|
|
Temp := (InBuf[I] shr 2);
|
|
OutBuf[O] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
|
|
{ One odd byte }
|
|
if (I = Count) then begin
|
|
Temp := (InBuf[I] shl 4) and $30;
|
|
OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
Inc(O, 2);
|
|
{ Two odd bytes }
|
|
end else begin
|
|
Temp := ((InBuf[I] shl 4) and $30) or ((InBuf[I+1] shr 4) and $0F);
|
|
OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
Temp := (InBuf[I+1] shl 2) and $3C;
|
|
OutBuf[O+2] := AnsiChar(IpUUTable[Temp and $3F]);
|
|
Inc(O, 3);
|
|
end;
|
|
end;
|
|
|
|
{ Add CR/LF }
|
|
OutBuf[O] := #13;
|
|
OutBuf[O+1] := #10;
|
|
|
|
{ Write line to stream }
|
|
FBody.Write(OutBuf, (O + 2));
|
|
DoOnCodingProgress(InStream.Position, InStream.Size, Abort);
|
|
until (Count < SizeOf(InBuf)) or Abort;
|
|
|
|
{ Add terminating end }
|
|
FBody.WriteLine('`');
|
|
FBody.WriteLine('end');
|
|
end;
|
|
|
|
{ Translate each 3 bytes into 4 hextets and encode according to table }
|
|
procedure TIpMimeEntity.OctetStreamToHextetStream(InStream : TStream;
|
|
OutStream : TIpAnsiTextStream;
|
|
const Table;
|
|
PadChar, Delim : AnsiChar);
|
|
var
|
|
OutBuf: array[0..MaxLineEncode-1] of Char; {!!.12}{!!.13}
|
|
OutBufLen: Integer; {!!.12}
|
|
Abort : Boolean;
|
|
|
|
procedure FlushOutBuf;
|
|
{- write out encoded buffer to message stream }
|
|
begin
|
|
if OutBufLen > 0 then begin {!!.12}
|
|
OutStream.WriteLineArray(OutBuf, OutBufLen);
|
|
OutBufLen := 0; {!!.12}
|
|
end;
|
|
end;
|
|
|
|
procedure OutChar(ch : AnsiChar);
|
|
{- buffer the character to go out }
|
|
begin
|
|
if OutBufLen >= MaxLineEncode - 1 then {!!.12}{!!.13}
|
|
FlushOutBuf;
|
|
OutBuf[OutBufLen] := Ch; {!!.12}
|
|
inc(OutBufLen); {!!.12}
|
|
end;
|
|
|
|
type
|
|
TBuffer = array[0..MaxInt-1] of Byte;
|
|
var
|
|
Buffer: ^TBuffer;
|
|
I, Count: Cardinal;
|
|
begin
|
|
if InStream is TMemoryStream then
|
|
Buffer := (InStream as TMemoryStream).Memory
|
|
else
|
|
if InStream is TIpMemMapStream then
|
|
Buffer := (InStream as TIpMemMapStream).Memory
|
|
else
|
|
raise EIpBaseException.Create(SNoMemoryStreamErr);
|
|
|
|
Abort := False;
|
|
OutBufLen := 0; {!!.12}
|
|
if (Delim <> #0) then
|
|
OutChar(Delim);
|
|
|
|
{ Encode and stream the attachment }
|
|
I := 0;
|
|
Count := InStream.Size div 3 * 3;
|
|
while I < Count do
|
|
begin
|
|
{ Encode 1st byte }
|
|
OutBuf[OutBufLen] := Char(TIp6BitTable(Table)[Buffer[I] shr 2]);
|
|
|
|
{ Encode 1st/2nd byte }
|
|
OutBuf[OutBufLen+1] := Char(TIp6BitTable(Table)[((Buffer[I] shl 4) or (Buffer[I+1] shr 4)) and $3F]);
|
|
|
|
{ Encode 2nd/3rd byte }
|
|
OutBuf[OutBufLen+2] := Char(TIp6BitTable(Table)[((Buffer[I+1] shl 2) or (Buffer[I+2] shr 6)) and $3F]);
|
|
|
|
{ Encode 3rd byte }
|
|
OutBuf[OutBufLen+3] := Char(TIp6BitTable(Table)[Buffer[I+2] and $3F]);
|
|
|
|
Inc(OutBufLen, 4);
|
|
if OutBufLen >= MaxLineEncode - 1 then {!!.12}{!!.13}
|
|
begin
|
|
FlushOutBuf;
|
|
if i mod 100 = 0 then
|
|
DoOnCodingProgress(I, Count, Abort);
|
|
if Abort then
|
|
break;
|
|
end;
|
|
Inc(I, 3);
|
|
end;
|
|
|
|
Count := InStream.Size;
|
|
{ Are there odd bytes to add? }
|
|
if (I < Count) then begin
|
|
OutChar(TIp6BitTable(Table)[Buffer[I] shr 2]);
|
|
|
|
{ One odd byte }
|
|
if I = Count-1 then begin
|
|
OutChar(TIp6BitTable(Table)[(Buffer[I] shl 4) and $30]);
|
|
|
|
if (PadChar <> #0) then
|
|
OutChar(PadChar);
|
|
{ Two odd bytes }
|
|
end else begin
|
|
OutChar(TIp6BitTable(Table)[((Buffer[I] shl 4) and $30) or (((Buffer[I+1] shr 4) and $0F)) and $3F]);
|
|
OutChar(TIp6BitTable(Table)[(Buffer[I+1] shl 2) and $3C]);
|
|
end;
|
|
{ Add padding }
|
|
if (PadChar <> #0) then
|
|
OutChar(PadChar);
|
|
end;
|
|
|
|
if (Delim <> #0) then
|
|
OutChar(Delim);
|
|
FlushOutBuf;
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
procedure TIpMIMEEntity.ReadBody(InStream : TIpAnsiTextStream; const StartLine : string);
|
|
var
|
|
S : string;
|
|
begin
|
|
S := StartLine;
|
|
{ read in message body up to message terminator '.' }
|
|
{while not ((S = '.') or AtEndOfStream) do begin}
|
|
while not InStream.AtEndOfStream do begin
|
|
Body.WriteLine(S);
|
|
S := InStream.ReadLine;
|
|
end;
|
|
{ write final line }
|
|
Body.WriteLine(S);
|
|
end;
|
|
{End !!.12}
|
|
|
|
|
|
{ TIpMessage }
|
|
constructor TIpMessage.CreateMessage;
|
|
begin
|
|
inherited Create(nil);
|
|
FBCC := TStringList.Create;
|
|
FCC := TStringList.Create;
|
|
FNewsgroups := TStringList.Create;
|
|
FPath := TStringList.Create;
|
|
FReceived := TStringList.Create;
|
|
FRecipients := TStringList.Create;
|
|
FReferences := TStringList.Create;
|
|
FUserFields := TStringList.Create;
|
|
FHeaders := TIpHeaderCollection.Create (Self); {!!.12}
|
|
MsgStream := TIpAnsiTextStream.CreateEmpty;
|
|
NewMessageStream;
|
|
end;
|
|
|
|
destructor TIpMessage.Destroy;
|
|
begin
|
|
Clear;
|
|
FBCC.Free;
|
|
FCC.Free;
|
|
FNewsgroups.Free;
|
|
FPath.Free;
|
|
FReceived.Free;
|
|
FRecipients.Free;
|
|
FReferences.Free;
|
|
FUserFields.Free;
|
|
FHeaders.Free; {!!.12}
|
|
MsgStream.FreeStream;
|
|
MsgStream.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{Begin !!.13}
|
|
procedure TIpMessage.CheckAllHeaders;
|
|
var
|
|
i : Integer;
|
|
j : Integer;
|
|
HeaderNum : Integer;
|
|
begin
|
|
FAttachmentCount := 0;
|
|
|
|
{ Roll through the list of headers specifically handled by iPRO.
|
|
When one is found, move it into the data structure specific to that
|
|
header field. }
|
|
for i := 0 to IpMaxHeaders - 1 do begin
|
|
if (IpHeaderXRef[i].FieldType = htUserFields) or
|
|
(IpHeaderXRef[i].FieldType = htReceived) then begin
|
|
for j := 0 to Headers.Count - 1 do begin
|
|
if StrLIComp (PChar (IpHeaderXRef[i].FieldString),
|
|
PChar (Headers.Items[j].Name),
|
|
Length (IpHeaderXRef[i].FieldString)) = 0 then
|
|
CheckHeaderType (Headers.Items[j],
|
|
IpHeaderXRef[i].FieldType);
|
|
end;
|
|
|
|
end else begin
|
|
HeaderNum := Headers.HasHeader (IpHeaderXRef[i].FieldString);
|
|
if HeaderNum >= 0 then
|
|
CheckHeaderType (Headers.Items[HeaderNum],
|
|
IpHeaderXRef[i].FieldType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIpMessage.CheckHeaderType (HeaderInfo : TIpHeaderItem;
|
|
HeaderType : TIpHeaderTypes);
|
|
|
|
function ExtractSingleHeader(HeaderInfo : TIpHeaderItem) : string;
|
|
begin
|
|
Result := Trim(HeaderInfo.Value.Text);
|
|
HeaderInfo.IsProperty := True; {!!.13}
|
|
end;
|
|
|
|
procedure ExtractCSVHeader(HeaderInfo : TIpHeaderItem;
|
|
var AList : TStringList);
|
|
var
|
|
WorkString : string;
|
|
begin
|
|
WorkString := ExtractSingleHeader(HeaderInfo);
|
|
Parse (WorkString, ',', AList);
|
|
HeaderInfo.IsProperty := True; {!!.13}
|
|
end;
|
|
|
|
procedure ExtractListHeader(HeaderInfo : TIpHeaderItem;
|
|
var AList : TStringList);
|
|
begin
|
|
AList.Assign (HeaderInfo.Value);
|
|
HeaderInfo.IsProperty := True; {!!.13}
|
|
end;
|
|
|
|
procedure ExtractAppendListHeader(HeaderInfo : TIpHeaderItem;
|
|
const IncludeName : Boolean; {!!.13}
|
|
var AList : TStringList);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := 0 to HeaderInfo.Value.Count - 1 do
|
|
{Begin !!.13}
|
|
if IncludeName then
|
|
AList.Add (HeaderInfo.Name + ': ' + HeaderInfo.Value[i])
|
|
else
|
|
AList.Add (HeaderInfo.Value[i]);
|
|
HeaderInfo.IsProperty := True;
|
|
{End !!.13}
|
|
end;
|
|
|
|
begin
|
|
case HeaderType of
|
|
htBCC :
|
|
ExtractCSVHeader(HeaderInfo, FBCC);
|
|
htCC :
|
|
ExtractCSVHeader(HeaderInfo, FCC);
|
|
htControl :
|
|
FControl := ExtractSingleHeader(HeaderInfo);
|
|
htDate :
|
|
FDate := ExtractSingleHeader(HeaderInfo);
|
|
htDispositionNotify :
|
|
FDispositionNotify := ExtractSingleHeader(HeaderInfo);
|
|
htFrom :
|
|
FFrom := ExtractSingleHeader(HeaderInfo);
|
|
htFollowUp :
|
|
FFollowUpTo := ExtractSingleHeader(HeaderInfo);
|
|
htInReplyTo :
|
|
FInReplyTo := ExtractSingleHeader(HeaderInfo);
|
|
htKeywords :
|
|
FKeywords := ExtractSingleHeader(HeaderInfo);
|
|
htMessageID :
|
|
FMessageID := ExtractSingleHeader(HeaderInfo);
|
|
htNewsgroups :
|
|
ExtractCSVHeader(HeaderInfo, FNewsgroups);
|
|
htNNTPPostingHost :
|
|
FNNTPPostingHost := ExtractSingleHeader(HeaderInfo);
|
|
htOrganization :
|
|
FOrganization := ExtractSingleHeader(HeaderInfo);
|
|
htPath :
|
|
ExtractListHeader(HeaderInfo, FPath);
|
|
htPostingHost :
|
|
FPostingHost := ExtractSingleHeader(HeaderInfo);
|
|
htReceived :
|
|
ExtractAppendListHeader(HeaderInfo, False, FReceived); {!!.13}
|
|
htReferences :
|
|
ExtractListHeader(HeaderInfo, FReferences);
|
|
htReplyTo :
|
|
FReplyTo := ExtractSingleHeader(HeaderInfo);
|
|
htReturnPath :
|
|
FReturnPath := ExtractSingleHeader(HeaderInfo);
|
|
htSender :
|
|
FSender := ExtractSingleHeader(HeaderInfo);
|
|
htSubject :
|
|
FSubject := ExtractSingleHeader(HeaderInfo);
|
|
htTo :
|
|
ExtractCSVHeader(HeaderInfo, FRecipients);
|
|
htUserFields :
|
|
ExtractAppendListHeader(HeaderInfo, True, FUserFields); {!!.13}
|
|
htXIpro : begin
|
|
end;
|
|
end;
|
|
end;
|
|
{End !!.12}
|
|
|
|
{ Clear properties and free message stream }
|
|
procedure TIpMessage.Clear;
|
|
begin
|
|
inherited Clear;
|
|
|
|
FAttachmentCount := 0; {!!.12}
|
|
FMessageTag := 0; {!!.15}
|
|
|
|
FBCC.Clear;
|
|
FCC.Clear;
|
|
FDate := '';
|
|
FDispositionNotify := ''; {!!.12}
|
|
FFrom := '';
|
|
FInReplyTo := '';
|
|
FKeywords := '';
|
|
FFollowupTo := ''; {!!.15}
|
|
FControl := ''; {!!.15}
|
|
FMessageID := '';
|
|
FNewsgroups.Clear;
|
|
FNNTPPostingHost := '';
|
|
FOrganization := '';
|
|
FPath.Clear;
|
|
FPostingHost := '';
|
|
FReceived.Clear;
|
|
FRecipients.Clear;
|
|
FReferences.Clear;
|
|
FReplyTo := '';
|
|
FReturnPath := '';
|
|
FSender := '';
|
|
FSubject := '';
|
|
FUserFields.Clear;
|
|
FHeaders.Clear; {!!.15}
|
|
MsgStream.FreeStream;
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
{ Get headers, body, and MIME parts (if any) }
|
|
procedure TIpMessage.DecodeMessage;
|
|
|
|
var
|
|
AttDepth : Integer;
|
|
|
|
function IsAttachmentStart (const s : string) : Boolean;
|
|
type
|
|
TAttState = (asBegin, asHaveBegin,
|
|
asNumber1, asNumberSp,
|
|
asOpenCurly, asNumber2, asNumber2Sp, asCloseCurly,
|
|
asQuote1, asDblQuote1, AsAlnum1);
|
|
|
|
var
|
|
State : TAttState;
|
|
i : Integer;
|
|
SLen : Integer;
|
|
|
|
begin
|
|
Result := False;
|
|
State := asBegin;
|
|
i := 1;
|
|
SLen := Length (s);
|
|
|
|
while i < SLen do begin
|
|
case State of
|
|
asBegin : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if LowerCase (Copy (s, i, 5)) = 'begin' then begin
|
|
State := asHaveBegin;
|
|
Inc (i, 5);
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asHaveBegin : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if s[i] = '{' then begin
|
|
Inc (i);
|
|
State := asNumber2;
|
|
end else if s[i] in ['0'..'9'] then begin
|
|
Inc (i);
|
|
State := asNumber1;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asNumber1 : begin
|
|
if s[i] in ['0'..'9'] then
|
|
Inc (i)
|
|
else if s[i] in [' ', #09] then begin
|
|
Inc (i);
|
|
State := asNumberSp;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asNumberSp : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if s[i] = '"' then begin
|
|
Inc (i);
|
|
State := asDblQuote1;
|
|
end else if s[i] = '''' then begin
|
|
Inc (i);
|
|
State := asQuote1;
|
|
end else if s[i] in ['!'..'~'] then begin
|
|
Inc (i);
|
|
State := asAlNum1;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asOpenCurly : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if s[i] in ['0'..'9'] then begin
|
|
Inc (i);
|
|
State := asNumber2;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asNumber2 : begin
|
|
if s[i] in ['0'..'9'] then
|
|
Inc (i)
|
|
else if s[i] in [' ', #09] then begin
|
|
Inc (i);
|
|
State := asNumber2Sp;
|
|
end else if s[i] = '}' then begin
|
|
State := asCloseCurly;
|
|
Inc (i);
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asNumber2Sp : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if s[i] = '}' then begin
|
|
Inc (i);
|
|
State := asCloseCurly;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asCloseCurly : begin
|
|
if s[i] in [' ', #09] then
|
|
Inc (i)
|
|
else if s[i] = '"' then begin
|
|
Inc (i);
|
|
State := asDblQuote1;
|
|
end else if s[i] = '''' then begin
|
|
Inc (i);
|
|
State := asQuote1;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asQuote1 : begin
|
|
if s[i] in [' '..'&', '('..'~'] then
|
|
Inc (i)
|
|
else if s[i] = '''' then begin
|
|
Result := True;
|
|
Break;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
asDblQuote1 : begin
|
|
if s[i] in [' '..'!', '#'..'~'] then
|
|
Inc (i)
|
|
else if s[i] = '"' then begin
|
|
Result := True;
|
|
Break;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
AsAlnum1 : begin
|
|
if s[i] in ['!'..'~'] then begin
|
|
Result := True;
|
|
Break;
|
|
end else
|
|
Break;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function IsAttachmentEnd (const s : string) : Boolean;
|
|
begin
|
|
if LowerCase (Copy (s, 1, 3)) = 'end' then
|
|
Result := True
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure CheckForAttachment (const s : string);
|
|
begin
|
|
if IsAttachmentStart (s) then begin
|
|
if AttDepth = 0 then
|
|
Inc (FAttachmentCount);
|
|
Inc (AttDepth);
|
|
end else if (IsAttachmentEnd (s)) and
|
|
(FAttachmentCount > 0) then
|
|
Dec (AttDepth);
|
|
end;
|
|
{End !!.12}
|
|
var
|
|
RawHeaders : TStringList;
|
|
S : string;
|
|
i, j : Integer; {!!.13}
|
|
begin
|
|
{ get message headers}
|
|
Position := 0;
|
|
RawHeaders := TStringList.Create;
|
|
try
|
|
S := ReadLine;
|
|
repeat
|
|
if S <> '' then {!!.15}
|
|
RawHeaders.Add(S);
|
|
S := ReadLine;
|
|
until (S = '');
|
|
|
|
FHeaders.Clear; {!!.12}
|
|
FHeaders.LoadHeaders (RawHeaders, False); {!!.12}
|
|
CheckAllHeaders; {!!.12}
|
|
|
|
{ decode MIME headers }
|
|
DecodeMimeHeaders(RawHeaders);
|
|
|
|
{Begin !!.13}
|
|
{ If this is a MIME message, mark the MIME headers as being exposed via an
|
|
iPRO property. }
|
|
if FIsMime then
|
|
for i := Low(IpMimeHeaders) to High(IpMimeHeaders) do begin
|
|
j := FHeaders.HasHeader(IpMimeHeaders[i]);
|
|
if j > -1 then
|
|
FHeaders.Items[j].IsProperty := True;
|
|
end;
|
|
{End !!.13}
|
|
finally
|
|
RawHeaders.Free;
|
|
end;
|
|
|
|
{ if message is mime, then decode mime parts }
|
|
if IsMime then begin {!!.01}
|
|
if (FContentDispositionType = strAttachment) then begin {!!.12}
|
|
Inc (FParent.FAttachmentCount); {!!.12}{!!.15}
|
|
DecodeEntityAsAttachment(MsgStream) {!!.01}
|
|
end else {!!.12}
|
|
DecodeEntity(MsgStream);
|
|
end else begin
|
|
{ otherwise, just read in the message body. }
|
|
repeat { skip over blank lines between headers and body }
|
|
S := ReadLine;
|
|
until (S <> '') or AtEndOfStream;
|
|
|
|
{ read in message body up to message terminator '.' }
|
|
{while not ((S = '.') or AtEndOfStream) do begin} {!!.10}
|
|
while not AtEndOfStream do begin {!!.10}
|
|
Body.WriteLine(S);
|
|
AttDepth := 0; {!!.12}
|
|
CheckForAttachment (S); {!!.12}
|
|
S := ReadLine;
|
|
end;
|
|
{ write final line } {!!.10}
|
|
if S <> '' then {!!.13}
|
|
Body.WriteLine(S); {!!.10}
|
|
|
|
{Begin !!.12}
|
|
{ Read the message body. }
|
|
{ReadBody(MsgStream, S); }
|
|
{End !!.12}
|
|
end;
|
|
Body.Position := 0;
|
|
end;
|
|
|
|
{ Build message stream with headers, body, and MIME parts (if any) }
|
|
procedure TIpMessage.EncodeMessage;
|
|
var
|
|
i : Integer;
|
|
Size : Longint; {!!.12}
|
|
FileName : string; {!!.12}
|
|
Strm : TIpMemMapStream; {!!.12}
|
|
RawHeaders : TStringList;
|
|
begin
|
|
NewMessageStream;
|
|
{Begin !!.12}
|
|
{ If we have some very large attachments then we need to use a memory mapped
|
|
file stream instead of TMemory, in order to improve performance. }
|
|
Size := 0;
|
|
for i := 0 to Pred(FMimeParts.Count) do
|
|
inc(Size, FMimeParts[i].FOriginalSize);
|
|
if Size > IpLgAttachSizeBoundry then begin
|
|
MsgStream.FreeStream;
|
|
FileName := GetTemporaryFile(GetTemporaryPath);
|
|
if FileExistsUTF8(FileName) then
|
|
DeleteFileUTF8(FileName);
|
|
Strm := TIpMemMapStream.Create(FileName, False, True);
|
|
Strm.Size := Trunc(Size * 1.5);
|
|
Strm.Open;
|
|
MsgStream.Stream := Strm;
|
|
end;
|
|
{End !!.12}
|
|
if (FContentType <> '') then begin
|
|
FIsMime := True;
|
|
FMimeVersion := '1.0';
|
|
end;
|
|
RawHeaders := TStringList.Create;
|
|
try
|
|
EncodeSingleHeader(strReturnPath, RawHeaders, FReturnPath);
|
|
EncodeMultiHeader(strReceived, RawHeaders, FReceived, #09, True);
|
|
EncodeListHeader(strPath, RawHeaders, FPath, ',', True);
|
|
EncodeListHeader(strNewsgroups, RawHeaders, FNewsgroups, ',', False); {!!.14}
|
|
EncodeSingleHeader(strMessageID, RawHeaders, FMessageID);
|
|
EncodeSingleHeader (strDispositionNotify, RawHeaders, {!!.12}
|
|
FDispositionNotify); {!!.12}
|
|
EncodeSingleHeader(strReplyTo, RawHeaders, FReplyTo);
|
|
EncodeSingleHeader(strFrom, RawHeaders, FFrom);
|
|
EncodeListHeader(strTo, RawHeaders, FRecipients, ',', True);
|
|
EncodeSingleHeader(strSubject, RawHeaders, FSubject);
|
|
EncodeSingleHeader(strDate, RawHeaders, FDate);
|
|
EncodeSingleHeader(strOrganization, RawHeaders, FOrganization);
|
|
EncodeListHeader(strCC, RawHeaders, FCC, ',', False);
|
|
EncodeListHeader(strBCC, RawHeaders, FBCC, ',', False);
|
|
EncodeSingleHeader(strInReplyTo, RawHeaders, FInReplyTo);
|
|
EncodeListHeader(strReferences, RawHeaders, FReferences, '', False);
|
|
EncodeSingleHeader(strSender, RawHeaders, FSender);
|
|
EncodeSingleHeader(strKeywords, RawHeaders, FKeywords);
|
|
EncodeMultiHeader('', RawHeaders, FUserFields, Char(0), False);
|
|
EncodeSingleHeader(strControl, RawHeaders, FControl); {!!.12}
|
|
EncodeSingleHeader(strFollowUp, RawHeaders, FFollowupTo); {!!.12}
|
|
{Begin !!.13}
|
|
for i := 0 to Pred(Headers.Count) do
|
|
{ Write the header out only if it is not a header exposed via an iPRO
|
|
property. }
|
|
if (not Headers.Items[i].IsProperty) then begin
|
|
if Headers.Items[i].Value.Count = 1 then
|
|
EncodeSingleHeader(Headers.Items[i].Name + ': ', RawHeaders,
|
|
Headers.Items[i].Value[0])
|
|
else
|
|
EncodeMultiheader(Headers.Items[i].Name + ': ', RawHeaders,
|
|
Headers.Items[i].Value, #09, True);
|
|
end;
|
|
{End !!.13}
|
|
if IsMime then
|
|
EncodeMimeHeaders(RawHeaders);
|
|
if (RawHeaders.Count = 0) then
|
|
Exit;
|
|
for i := 0 to Pred(RawHeaders.Count) do
|
|
WriteLine(RawHeaders[i]);
|
|
finally
|
|
RawHeaders.Free;
|
|
end;
|
|
|
|
{Begin !!.13}
|
|
WriteLine('');
|
|
if IsMime then
|
|
EncodeEntity(MsgStream)
|
|
else if (FBody.Size > 0) then begin
|
|
FBody.Position := 0;
|
|
repeat
|
|
WriteLine(Body.ReadLine);
|
|
until FBody.AtEndOfStream;
|
|
end; { if }
|
|
{End !!.13}
|
|
end;
|
|
|
|
{ Load message from file stream and decode }
|
|
procedure TIpMessage.LoadFromFile(const aFileName : string);
|
|
{Begin !!.12}
|
|
var
|
|
SourceStream : TIpMemMapStream;
|
|
{End !!.12}
|
|
begin
|
|
Clear;
|
|
NewMessageStream; {!!.03}
|
|
{Begin !!.12}
|
|
SourceStream := TIpMemMapStream.Create(aFileName, True, False);
|
|
try
|
|
SourceStream.Open;
|
|
{Begin !!.15}
|
|
if SourceStream.Size > IpLgAttachSizeBoundry then begin
|
|
MsgStream.FreeStream;
|
|
MsgStream.Stream := SourceStream;
|
|
end
|
|
else
|
|
MsgStream.CopyFrom(SourceStream, 0);
|
|
finally
|
|
if MsgStream.Stream <> SourceStream then
|
|
SourceStream.Free;
|
|
{End !!.15}
|
|
end;
|
|
{End !!.12}
|
|
|
|
try {!!.03}
|
|
DecodeMessage;
|
|
except {!!.03}
|
|
{ just eat the exception, the messge might be corrupt, but the }
|
|
{ raw text (MessageStream property) will still be available }
|
|
end; {!!.03}
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
procedure TIpMessage.LoadFromStream(aStream : TStream);
|
|
var
|
|
FileName : string;
|
|
Strm : TIpMemMapStream;
|
|
begin
|
|
Clear;
|
|
NewMessageStream;
|
|
if aStream.Size > IpLgAttachSizeBoundry then begin
|
|
MsgStream.FreeStream;
|
|
FileName := GetTemporaryFile(GetTemporaryPath);
|
|
if FileExistsUTF8(FileName) then
|
|
DeleteFileUTF8(FileName);
|
|
Strm := TIpMemMapStream.Create(FileName, False, True);
|
|
Strm.Size := aStream.Size;
|
|
Strm.Open;
|
|
MsgStream.Stream := Strm;
|
|
end;
|
|
MsgStream.CopyFrom(aStream, 0);
|
|
|
|
try
|
|
DecodeMessage;
|
|
except
|
|
{ just eat the exception, the messge might be corrupt, but the }
|
|
{ raw text (MessageStream property) will still be available }
|
|
end;
|
|
end;
|
|
|
|
|
|
{ Create new message stream but retain existing decoded message }
|
|
procedure TIpMessage.NewMessageStream;
|
|
begin
|
|
MsgStream.FreeStream;
|
|
MsgStream.Stream := TMemoryStream.Create;
|
|
MsgStream.bsInitForNewStream; {!!.02}
|
|
end;
|
|
|
|
{ Clear all and create new empty message stream }
|
|
procedure TIpMessage.NewMessage;
|
|
begin
|
|
Clear;
|
|
NewMessageStream;
|
|
end;
|
|
|
|
{ Position property read access method }
|
|
function TIpMessage.GetPosition : Longint;
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
Result := MsgStream.Position
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{ Size property read access method }
|
|
function TIpMessage.GetSize : Longint;
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
Result := MsgStream.Size
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{ Return next line from the message stream (CRLF stripped) }
|
|
function TIpMessage.ReadLine : string;
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
Result := MsgStream.ReadLine
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
{ Return next line from the message stream (CRLF retained) }
|
|
function TIpMessage.ReadLineCRLF : string;
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
Result := MsgStream.ReadLine + CRLF
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
{- Save raw message stream to file }
|
|
procedure TIpMessage.SaveToFile(const aFileName : string);
|
|
var
|
|
FS : TFileStream;
|
|
begin
|
|
EncodeMessage;
|
|
Position := 0;
|
|
FS := TFileStream.Create(UTF8ToSys(aFileName), fmCreate);
|
|
try
|
|
FS.CopyFrom(MsgStream, MsgStream.Size);
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
end;
|
|
|
|
{Begin !!.12}
|
|
{- Save raw message stream }
|
|
procedure TIpMessage.SaveToStream(Stream: TStream);
|
|
begin
|
|
Position := 0;
|
|
Stream.CopyFrom(MsgStream, MsgStream.Size);
|
|
end;
|
|
|
|
procedure TIpMessage.SetHeaders(Headers : TIpHeaderCollection);
|
|
begin
|
|
FHeaders.Assign(Headers);
|
|
end;
|
|
{End !!.12}
|
|
|
|
{ Position property write access method }
|
|
procedure TIpMessage.SetPosition(Value : Longint);
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
MsgStream.Position := Value;
|
|
end;
|
|
|
|
{ Write string onto the message stream and append CRLF terminator }
|
|
procedure TIpMessage.WriteLine(const aSt : string);
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
MsgStream.WriteLine(aSt);
|
|
end;
|
|
|
|
{ Indicates whether or not we're at the end of the message stream }
|
|
function TIpMessage.AtEndOfStream : Boolean;
|
|
begin
|
|
if Assigned(MsgStream) then
|
|
Result := MsgStream.AtEndOfStream
|
|
else
|
|
Result := True;
|
|
end;
|
|
|
|
{ Return 'alternative' text/plain mime part }
|
|
function TIpMessage.GetBodyPlain(CanCreate : Boolean) : TIpMimeEntity;
|
|
var
|
|
aParent : TIpMimeEntity;
|
|
begin
|
|
aParent := FindNestedMimePart(strMultipart, strAlternative, ''); {!!.02}
|
|
if not Assigned(aParent) then
|
|
aParent := Self;
|
|
{Begin !!.15}
|
|
Result := aParent.FindNestedMimePart(strText, strPlain, '');
|
|
if (Result = nil) and CanCreate then begin
|
|
Result := NewMimePart;
|
|
Result.ContentType := strText;
|
|
Result.ContentSubtype := strPlain;
|
|
end;
|
|
{End !!.15}
|
|
end;
|
|
|
|
{ Return 'alternative' text/html mime part }
|
|
function TIpMessage.GetBodyHtml(CanCreate : Boolean) : TIpMimeEntity;
|
|
var
|
|
aParent : TIpMimeEntity;
|
|
begin
|
|
aParent := FindNestedMimePart(strMultipart, strAlternative, ''); {!!.02}
|
|
if not Assigned(aParent) then
|
|
aParent := Self;
|
|
{Begin !!.15}
|
|
Result := aParent.FindNestedMimePart(strText, strHtml, '');
|
|
if (Result = nil) and CanCreate then begin
|
|
Result := NewMimePart;
|
|
Result.ContentType := strText;
|
|
Result.ContentSubtype := strHTML;
|
|
end;
|
|
{End !!.15}
|
|
end;
|
|
|
|
{ Add a file attachment using default types }
|
|
procedure TIpMessage.AddDefaultAttachment(const aFileName: string); {!!.02}
|
|
begin
|
|
with NewMimePart do begin
|
|
EntityName := ExtractFileName(aFileName);
|
|
ContentDispositionType := 'attachment';
|
|
EncodeBodyFile(aFileName);
|
|
end;
|
|
end;
|
|
|
|
procedure TIpMessage.AddDefaultAttachmentAs (const aFileName : string; {!!.12}
|
|
const AttachmentName : string); {!!.12}
|
|
begin {!!.12}
|
|
with NewMimePart do begin {!!.12}
|
|
EntityName := ExtractFileName (AttachmentName); {!!.12}
|
|
ContentDispositionType := 'attachment'; {!!.12}
|
|
EncodeBodyFile (aFileName); {!!.12}
|
|
end; {!!.12}
|
|
end; {!!.12}
|
|
|
|
{ Set message properties from another TIpMessage }
|
|
procedure TIpMessage.Assign(Source: TPersistent);
|
|
var
|
|
SourcePos : Integer;
|
|
SourceMsg : TIpMessage;
|
|
begin
|
|
if Source is TIpMessage then begin
|
|
SourceMsg := TIpMessage(Source);
|
|
{ clear our streams and properties }
|
|
NewMessage;
|
|
{ ensure we are at the beginning of our streams }
|
|
Position := 0;
|
|
SourcePos := SourceMsg.Position;
|
|
SourceMsg.Position := 0;
|
|
MsgStream.CopyFrom(SourceMsg.MsgStream, 0);
|
|
Position := 0;
|
|
SourceMsg.Position := SourcePos;
|
|
try {!!.03}
|
|
DecodeMessage;
|
|
except {!!.03}
|
|
{ just eat the exception, the messge might be corrupt, but the }
|
|
{ raw text (MessageStream property) will still be available }
|
|
end; {!!.03}
|
|
end else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TIpMessage.SetBCC(const Value: TStringList); {!!.01}
|
|
begin
|
|
FBCC.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetCC(const Value: TStringList); {!!.01}
|
|
begin
|
|
FCC.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetNewsgroups(const Value: TStringList); {!!.01}
|
|
begin
|
|
FNewsgroups.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetPath(const Value: TStringList); {!!.01}
|
|
begin
|
|
FPath.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetReceived(const Value: TStringList); {!!.01}
|
|
begin
|
|
FReceived.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetRecipients(const Value: TStringList); {!!.01}
|
|
begin
|
|
FRecipients.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetReferences(const Value: TStringlist); {!!.01}
|
|
begin
|
|
FReferences.Assign(Value);
|
|
end;
|
|
|
|
procedure TIpMessage.SetUserFields(const Value: TStringList); {!!.01}
|
|
begin
|
|
FUserFields.Assign(Value);
|
|
end;
|
|
|
|
|
|
|
|
{ TIpFormDataEntity }
|
|
constructor TIpFormDataEntity.Create(ParentEntity : TIpMimeEntity);
|
|
begin
|
|
inherited Create(ParentEntity);
|
|
ContentType := strMultipart;
|
|
ContentSubType := strFormData;
|
|
Boundary := GenerateBoundary;
|
|
end;
|
|
|
|
destructor TIpFormDataEntity.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ Add file as nested Mime part of FilesEntity block }
|
|
procedure TIpFormDataEntity.AddFile(const aFileName,
|
|
aContentType,
|
|
aSubtype : string;
|
|
aEncoding : TIpMimeEncodingMethod);
|
|
var
|
|
Blk : TIpMimeEntity;
|
|
MS : TIpMemMapStream;
|
|
begin
|
|
if not Assigned(FFilesEntity) then begin
|
|
FFilesEntity := NewMimePart;
|
|
FFilesEntity.EntityName := strFiles;
|
|
FFilesEntity.ContentDispositionType := strFormData;
|
|
FFilesEntity.ContentType := strMultipart;
|
|
FFilesEntity.ContentSubtype := strMixed;
|
|
end;
|
|
|
|
Blk := FFilesEntity.NewMimePart;
|
|
Blk.ContentDispositionType := strAttachment;
|
|
Blk.ContentType := aContentType;
|
|
Blk.ContentSubtype := aSubtype;
|
|
Blk.ContentTransferEncoding := aEncoding;
|
|
|
|
MS := TIpMemMapStream.Create(aFileName, True, False);
|
|
try
|
|
MS.Open;
|
|
Blk.EncodeBodyStream(MS, aFileName);
|
|
finally
|
|
MS.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Add FormData Mime part }
|
|
procedure TIpFormDataEntity.AddFormData(const aName, aText : string);
|
|
var
|
|
Blk : TIpMimeEntity;
|
|
begin
|
|
Blk := NewMimePart;
|
|
Blk.EntityName := aName;
|
|
Blk.ContentDispositionType := strFormData;
|
|
Blk.Body.WriteLine(aText);
|
|
end;
|
|
|
|
{ Generate raw Mime message and save to stream }
|
|
procedure TIpFormDataEntity.SaveToStream(aStream : TStream);
|
|
var
|
|
TS : TIpAnsiTextStream;
|
|
SL : TStringList;
|
|
begin
|
|
TS := TIpAnsiTextStream.Create(aStream);
|
|
try
|
|
SL := TStringList.Create;
|
|
try
|
|
EncodeMimeHeaders(SL);
|
|
SL.SaveToStream(TS);
|
|
EncodeEntity(TS);
|
|
finally
|
|
SL.Free;
|
|
end;
|
|
finally
|
|
TS.Free;
|
|
end;
|
|
end;
|
|
|
|
{HTTP Authentication Support -- .02}
|
|
function IpBase64EncodeString(const InStr: string): string; {!!.03}
|
|
{
|
|
encode a string into Base64, intended for producing short ( < 100 chars or so)
|
|
coded strings to be passed as part of HTTP authentications via HTTP headers.
|
|
|
|
NO LINE ORIENTED SMARTS: if you need to work with blocks of text use the
|
|
IpMsg class
|
|
}
|
|
var
|
|
CvtBuff: PChar;
|
|
I, Ct, Count, OutLen: Cardinal;
|
|
|
|
function CodeByte(byt : Byte) : char;
|
|
{- encode 6-bit value to BinHex char and send it }
|
|
begin
|
|
Result := Ip64Table[byt and $3F];
|
|
end;
|
|
|
|
begin
|
|
Result := '';
|
|
Count := Length(InStr);
|
|
if Count = 0 then // empty input string nothing to encode {!!.03}
|
|
Exit; {!!.03}
|
|
OutLen := Count * 2; // leave plenty of room for encoded string {!!.03}
|
|
GetMem(CvtBuff, OutLen + 1);
|
|
|
|
Ct := 0;
|
|
I := 1;
|
|
|
|
if Count >= 3 then begin {!!.03}
|
|
while I <= (Count - 2) do begin
|
|
{ Encode 1st byte }
|
|
CvtBuff[Ct] := CodeByte(Ord(InStr[I]) shr 2);
|
|
Inc(Ct);
|
|
|
|
{ Encode 1st/2nd byte }
|
|
CvtBuff[Ct] := CodeByte((Ord(InStr[I]) shl 4) or (Ord(InStr[I+1]) shr 4));
|
|
Inc(Ct);
|
|
|
|
{ Encode 2nd/3rd byte }
|
|
CvtBuff[Ct] := CodeByte((Ord(InStr[I+1]) shl 2) or (Ord(InStr[I+2]) shr 6));
|
|
Inc(Ct);
|
|
|
|
{ Encode 3rd byte }
|
|
CvtBuff[Ct] := CodeByte(Ord(InStr[I+2]) and $3F);
|
|
Inc(Ct);
|
|
|
|
Inc(I, 3);
|
|
end;
|
|
end; {!!.03}
|
|
|
|
{ Are there odd bytes to add? }
|
|
if (I <= Count) then begin
|
|
CvtBuff[Ct] := CodeByte(Ord(InStr[I]) shr 2);
|
|
Inc(Ct);
|
|
|
|
{ One odd byte }
|
|
if I = Count then begin
|
|
CvtBuff[Ct] := CodeByte((Ord(InStr[I]) shl 4) and $30);
|
|
Inc(Ct);
|
|
CvtBuff[Ct] := '='; // pad char
|
|
Inc(Ct);
|
|
{ Two odd bytes }
|
|
end else begin
|
|
CvtBuff[Ct] := CodeByte(((Ord(InStr[I]) shl 4) and $30)
|
|
or ((Ord(InStr[I+1]) shr 4) and $0F));
|
|
Inc(Ct);
|
|
CvtBuff[Ct] := CodeByte((Ord(InStr[I+1]) shl 2) and $3C);
|
|
Inc(Ct);
|
|
end;
|
|
{ Add padding }
|
|
CvtBuff[Ct] := '=';
|
|
Inc(Ct);
|
|
end;
|
|
|
|
CvtBuff[Ct] := #0;
|
|
Result := StrPas(CvtBuff);
|
|
FreeMem(CvtBuff, OutLen + 1);
|
|
end;
|
|
|
|
|
|
end.
|