{******************************************************************} {* 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 SourceForge: mkaemmerer * * ***** END LICENSE BLOCK ***** *) { Global defines potentially affecting this unit } {$I IPDEFINE.INC} unit IpMsg; interface uses Classes, SysUtils, LCLType, LCLIntf, LazFileUtils, LazStringUtils, IpStrms, 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; 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; FProperty : Boolean; 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 IsProperty : Boolean read FProperty write FProperty; { Set to True if this header is exposed via an iPRO property. } 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); function HasHeader(const 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; 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; FRelatedSubtype : string; FRelatedStart : string; FRelatedStartInfo : string; FAttachmentCount : Integer; protected {methods} procedure Clear; virtual; procedure ClearBodyLargeAttach(const AttachmentSize : Longint); virtual; function ContainsSpecialChars(const Value : string) : Boolean; 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; function EncodeEntity(OutStream : TIpAnsiTextStream) : string; procedure ReadBody(InStream : TIpAnsiTextStream; const StartLine : string); 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; function GetMimePart(const aType, aSubType, aContentID : string; CanCreate : Boolean) : TIpMimeEntity; function NewMimePart : TIpMimeEntity; property AttachmentCount : Integer read FAttachmentCount; 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 read FRelatedStart write FRelatedStart; property RelatedStartInfo : string read FRelatedStartInfo write FRelatedStartInfo; property RelatedSubtype : string read FRelatedSubtype write FRelatedSubtype; property RelatedType : string 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; FControl : string; 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; FDispositionNotify: string; protected {methods} procedure CheckAllHeaders; procedure CheckHeaderType (HeaderInfo : TIpHeaderItem; HeaderType : TIpHeaderTypes); 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); procedure AddDefaultAttachmentAs (const aFileName : string; const AttachmentName : string); 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); procedure NewMessage; function ReadLine : string; function ReadLineCRLF : string; procedure SaveToFile(const aFileName : string); procedure SaveToStream(Stream: TStream); procedure SetHeaders(Headers : TIpHeaderCollection); procedure WriteLine(const aSt : string); public {properties} property BCC : TStringList read FBCC write SetBCC; property CC : TStringList read FCC write SetCC; property Control : string read FControl write FControl; property Date : string read FDate write FDate; property DispositionNotification : string read FDispositionNotify write FDispositionNotify; property FollowupTo : String read FFollowupTo Write FFollowupTo; property From : string read FFrom write FFrom; property Headers : TIpHeaderCollection read FHeaders write SetHeaders; property InReplyTo : string read FInReplyTo write FInReplyTo; property Keywords : string read FKeywords write FKeywords; property MessageID : string read FMessageID write FMessageID; property MessageStream : TIpAnsiTextStream read MsgStream; property MessageTag : Integer read FMessageTag write FMessageTag; property Newsgroups : TStringList read FNewsgroups write SetNewsgroups; property NNTPPostingHost : string read FNNTPPostingHost write FNNTPPostingHost; property Organization : string read FOrganization write FOrganization; property Path : TStringList read FPath write SetPath; property Position : Longint read GetPosition write SetPosition; property PostingHost : string read FPostingHost write FPostingHost; property Received : TStringList read FReceived write SetReceived; property Recipients : TStringList read FRecipients write SetRecipients; property References : TStringlist read FReferences write SetReferences; 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; 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; 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; function IpBase64EncodeString(const InStr: string): string; 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: '; strControl = 'Control: '; 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' ); { 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'; { MIME content disposition parameters } strAttachment = 'attachment'; strInline = 'inline'; strCreationDate = 'creation-date='; strFilename = 'filename='; strModificationDate = 'modification-date='; strReadDate = 'read-date='; strStart = 'start='; strStartInfo = 'start-info='; strSize = 'size='; strType = 'type='; { 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 } {%H-}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 = ( $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; {%H-}BinHexFileType : array[0..3] of Byte = ($49, $42, $4D, $3F); { "IBM?" } CRLF = #13#10; MaxLine = 1000; MaxLineEncode = 77; { Maximum line length for QuotablePrintable & Base64 encoding. } 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; Str2 : string; CaseSensitive : Boolean) : Boolean; begin if CaseSensitive then Result := (Str1 = Str2) else Result := StrIComp (PChar (Str1), PChar (Str2)) = 0; end; { Parse string into string list } procedure Parse(const Line : string; Delim : AnsiChar; 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); 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 {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; 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; 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 RawHeaders.Add(S); S := Delim; 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(GetTickCount64, 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; { TIpHeaderItem ****************************************************** } constructor TIpHeaderItem.Create (Collection : TCollection); begin inherited Create (Collection); FCollection := TIpHeaderCollection.Create ( TIpHeaderCollection(Collection).FOwner); FValue := TStringList.Create; FName := ''; FProperty := False; 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; end; procedure TIpHeaderItem.SetValue (v : TStringList); begin FValue.Assign (v); end; { TIpHeaderCollection ************************************************ } constructor TIpHeaderCollection.Create(AOwner : TPersistent); begin inherited Create (TIpHeaderItem); FOwner := AOwner; end; function TIpHeaderCollection.GetItem (Index : Integer) : TIpHeaderItem; begin Result := TIpHeaderItem (inherited GetItem (Index)); end; function TIpHeaderCollection.GetOwner : TPersistent; begin Result := FOwner; end; function TIpHeaderCollection.HasHeader(const AName : string) : Integer; var i : Integer; begin for i := 0 to Count - 1 do if CompareText(Items[i].Name, AName) = 0 then Exit(i); Result := -1; 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; {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); Inc(CurLine); while IsWrappedLine (AHeaderList, CurLine) do begin WorkLine := WorkLine + #9 + Trim(AHeaderList[CurLine]); Inc(CurLine); end; NewField.Value.Add (Trim (WorkLine)); 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); end else Inc(i); end; end; procedure TIpHeaderCollection.SetItem (Index : Integer; Value : TIpHeaderItem); begin inherited SetItem (Index, Value); end; { 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; { 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; { 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 := ''; FRelatedSubtype := ''; FRelatedStart := ''; FRelatedStartInfo := ''; 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; i, LeadingBlankLines : Integer; begin Decoded := False; LeadingBlankLines := 0; { 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 } if (StrLIComp(PChar(strContent), PChar(Result), Length(strContent)) = 0) or (StrLIComp(PChar(strMimeVersion), PChar(Result), Length(strMimeVersion)) = 0) then begin 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 } 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 while not (((FParentBoundary <> '') and (Result = '--' + FParentBoundary) ) or InStream.AtEndOfStream) do begin 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 (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 Body.WriteLine(''); Body.WriteLine(Result); Result := InStream.ReadLine; end; if InStream.AtEndOfStream then break; LeadingBlankLines := 0; end; { 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; { 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); { 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; finally RawParams.Free; end; end; { Decode Content-TranferEncoding header field } function TIpMimeEntity.DecodeContentTransferEncoding(const aEncoding : string) : TIpMimeEncodingMethod; begin if CompareText(aEncoding, str7Bit) = 0 then Result := em7bit else if CompareText(aEncoding, str8Bit) = 0 then Result := em8bit else if CompareText(aEncoding, strBase64) = 0 then Result := emBase64 else if CompareText(aEncoding, strBinary) = 0 then Result := emBinary else if CompareText(aEncoding, strBinHex) = 0 then Result := emBinHex else if CompareText(aEncoding, strQuoted) = 0 then Result := emQuoted else if CompareText(aEncoding, strUUEncode) = 0 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 Inc (FParent.FAttachmentCount); 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 } OutStream.Position := OutStream.Size - 1; TIpBufferedStream(OutStream).ReadChar(Ch); if ((Ch <> #13) and (Ch <> #10)) then OutStream.WriteLine(''); 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; 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; { 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); 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 } 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} { 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; 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); 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; 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; 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; 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; 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; 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); try FS.Open; 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); 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(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; { 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 (IsSameString (MimeParts[i].ContentID, aContentID, False)) then begin Result := MimeParts[i]; Break; end else if (IsSameString (MimeParts[i].ContentType, aType, False)) and (IsSameString (MimeParts[i].ContentSubtype, aSubType, False)) then begin 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 } var I : Integer; C : Char; InBuf : array[0..3] of Char; {%H-}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 := '===='; 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); end; end; { Decode InStream to OutStream - BinHex } procedure TIpMimeEntity.DecodeBinHex(OutStream : TStream); var InBuf : array[1..4] of Byte; {%H-}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; HeaderLength : byte; 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); FillChar(Header, SizeOf(Header), #0); WS2.Position := 0; WS2.Read(HeaderLength, SizeOf (Byte)); WS2.Read(HeaderFileName, HeaderLength); 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; I : integer; InBuf : array[0..pred (MaxLine)] of Byte; OutBuf : array[0..pred (MaxLine)] of Byte; 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 raise EIpBaseException.Create(SLineLengthErr); 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;} 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; {%H-}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; {%H-}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 } HeaderFileName := UpperCase(ExtractFileName(aFileName)); if (Length(aFileName) >= MaxLine) then SetLength(HeaderFileName, 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; {%H-}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; OutBufLen: Integer; Abort : Boolean; procedure FlushOutBuf; {- write out encoded buffer to message stream } begin if OutBufLen > 0 then begin OutStream.WriteLineArray(OutBuf, OutBufLen); OutBufLen := 0; end; end; procedure OutChar(ch : AnsiChar); {- buffer the character to go out } begin if OutBufLen >= MaxLineEncode - 1 then FlushOutBuf; OutBuf[OutBufLen] := Ch; inc(OutBufLen); 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; 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 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; 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; { 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); 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; MsgStream.FreeStream; MsgStream.Free; inherited Destroy; end; 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; end; procedure ExtractCSVHeader(HeaderInfo : TIpHeaderItem; var AList : TStringList); var WorkString : string; begin WorkString := ExtractSingleHeader(HeaderInfo); Parse (WorkString, ',', AList); HeaderInfo.IsProperty := True; end; procedure ExtractListHeader(HeaderInfo : TIpHeaderItem; var AList : TStringList); begin AList.Assign (HeaderInfo.Value); HeaderInfo.IsProperty := True; end; procedure ExtractAppendListHeader(HeaderInfo : TIpHeaderItem; const IncludeName : Boolean; var AList : TStringList); var i : Integer; begin for i := 0 to HeaderInfo.Value.Count - 1 do if IncludeName then AList.Add (HeaderInfo.Name + ': ' + HeaderInfo.Value[i]) else AList.Add (HeaderInfo.Value[i]); HeaderInfo.IsProperty := True; 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); 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); htXIpro : begin end; end; end; { Clear properties and free message stream } procedure TIpMessage.Clear; begin inherited Clear; FAttachmentCount := 0; FMessageTag := 0; FBCC.Clear; FCC.Clear; FDate := ''; FDispositionNotify := ''; FFrom := ''; FInReplyTo := ''; FKeywords := ''; FFollowupTo := ''; FControl := ''; FMessageID := ''; FNewsgroups.Clear; FNNTPPostingHost := ''; FOrganization := ''; FPath.Clear; FPostingHost := ''; FReceived.Clear; FRecipients.Clear; FReferences.Clear; FReplyTo := ''; FReturnPath := ''; FSender := ''; FSubject := ''; FUserFields.Clear; FHeaders.Clear; MsgStream.FreeStream; end; { 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 CompareText(Copy(s,i,5), 'begin') = 0 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; procedure CheckForAttachment (const s : string); begin if IsAttachmentStart (s) then begin if AttDepth = 0 then Inc (FAttachmentCount); Inc (AttDepth); end else if LazStartsText('end', s) and (FAttachmentCount > 0) then Dec (AttDepth); end; var RawHeaders : TStringList; S : string; i, j : Integer; begin { get message headers} Position := 0; RawHeaders := TStringList.Create; try S := ReadLine; repeat if S <> '' then RawHeaders.Add(S); S := ReadLine; until (S = ''); FHeaders.Clear; FHeaders.LoadHeaders (RawHeaders, False); CheckAllHeaders; { decode MIME headers } DecodeMimeHeaders(RawHeaders); { 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; finally RawHeaders.Free; end; { if message is mime, then decode mime parts } if IsMime then begin if (FContentDispositionType = strAttachment) then begin Inc (FParent.FAttachmentCount); DecodeEntityAsAttachment(MsgStream) end else 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} while not AtEndOfStream do begin Body.WriteLine(S); AttDepth := 0; CheckForAttachment (S); S := ReadLine; end; { write final line } if S <> '' then Body.WriteLine(S); { Read the message body. } {ReadBody(MsgStream, S); } end; Body.Position := 0; end; { Build message stream with headers, body, and MIME parts (if any) } procedure TIpMessage.EncodeMessage; var i : Integer; Size : Longint; FileName : string; Strm : TIpMemMapStream; RawHeaders : TStringList; begin NewMessageStream; { 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; 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); EncodeSingleHeader(strMessageID, RawHeaders, FMessageID); EncodeSingleHeader (strDispositionNotify, RawHeaders, FDispositionNotify); 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); EncodeSingleHeader(strFollowUp, RawHeaders, FFollowupTo); 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; 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; 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; { Load message from file stream and decode } procedure TIpMessage.LoadFromFile(const aFileName : string); var SourceStream : TIpMemMapStream; begin Clear; NewMessageStream; SourceStream := TIpMemMapStream.Create(aFileName, True, False); try SourceStream.Open; 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; try DecodeMessage; except { just eat the exception, the messge might be corrupt, but the } { raw text (MessageStream property) will still be available } end; end; 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; 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(aFileName, fmCreate); try FS.CopyFrom(MsgStream, MsgStream.Size); finally FS.Free; end; end; {- 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; { 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, ''); if not Assigned(aParent) then aParent := Self; Result := aParent.FindNestedMimePart(strText, strPlain, ''); if (Result = nil) and CanCreate then begin Result := NewMimePart; Result.ContentType := strText; Result.ContentSubtype := strPlain; end; end; { Return 'alternative' text/html mime part } function TIpMessage.GetBodyHtml(CanCreate : Boolean) : TIpMimeEntity; var aParent : TIpMimeEntity; begin aParent := FindNestedMimePart(strMultipart, strAlternative, ''); if not Assigned(aParent) then aParent := Self; Result := aParent.FindNestedMimePart(strText, strHtml, ''); if (Result = nil) and CanCreate then begin Result := NewMimePart; Result.ContentType := strText; Result.ContentSubtype := strHTML; end; end; { Add a file attachment using default types } procedure TIpMessage.AddDefaultAttachment(const aFileName: string); begin with NewMimePart do begin EntityName := ExtractFileName(aFileName); ContentDispositionType := 'attachment'; EncodeBodyFile(aFileName); end; end; procedure TIpMessage.AddDefaultAttachmentAs (const aFileName : string; const AttachmentName : string); begin with NewMimePart do begin EntityName := ExtractFileName (AttachmentName); ContentDispositionType := 'attachment'; EncodeBodyFile (aFileName); end; end; { 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 DecodeMessage; except { just eat the exception, the messge might be corrupt, but the } { raw text (MessageStream property) will still be available } end; end else inherited Assign(Source); end; procedure TIpMessage.SetBCC(const Value: TStringList); begin FBCC.Assign(Value); end; procedure TIpMessage.SetCC(const Value: TStringList); begin FCC.Assign(Value); end; procedure TIpMessage.SetNewsgroups(const Value: TStringList); begin FNewsgroups.Assign(Value); end; procedure TIpMessage.SetPath(const Value: TStringList); begin FPath.Assign(Value); end; procedure TIpMessage.SetReceived(const Value: TStringList); begin FReceived.Assign(Value); end; procedure TIpMessage.SetRecipients(const Value: TStringList); begin FRecipients.Assign(Value); end; procedure TIpMessage.SetReferences(const Value: TStringlist); begin FReferences.Assign(Value); end; procedure TIpMessage.SetUserFields(const Value: TStringList); 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; { 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 Exit; OutLen := Count * 2; // leave plenty of room for encoded string GetMem(CvtBuff, OutLen + 1); Ct := 0; I := 1; if Count >= 3 then begin 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; { 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.