/components/turbopower_ipro/ipmsg.pas

{******************************************************************}
{*               IPMSG.PAS - MIME message classes                 *}
{******************************************************************}

{ $Id$ }

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Internet Professional
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 2000-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * Markus Kaemmerer <mk@happyarts.de> SourceForge: mkaemmerer
 *
 * ***** END LICENSE BLOCK ***** *)

{ Global defines potentially affecting this unit }

{$I IPDEFINE.INC}

unit IpMsg;

interface

uses
  {$IFDEF IP_LAZARUS}
  LCLType,
  LCLIntf,
  LazFileUtils, LazUTF8Classes,
  {$ELSE}
  Windows,
  {$ENDIF}
  Classes,
  SysUtils,
  IpStrms,
  {$IFNDEF IP_LAZARUS}
  //IpSock, //JMN
  {$ENDIF}
  IpUtils,
  IpConst;

type
  TIpMimeEncodingMethod = (em7Bit, em8Bit, emBase64, emBinary, emBinHex,
                           emQuoted, emUUEncode, emUnknown);


{ TIpMimeEntity }
type
  TIpCodingProgressEvent = procedure(Sender : TObject; Progress : Byte;
                                     var Abort : Boolean) of object;

{Begin !!.12}
type
  TIpHeaderTypes = (htBCC, htCC, htControl, htDate, htDispositionNotify,
                    htFollowUp, htFrom, htInReplyTo, htKeywords,
                    htMessageID, htNewsgroups, htNNTPPostingHost,
                    htOrganization, htPath, htPostingHost, htReceived,
                    htReferences, htReplyTo, htReturnPath, htSender,
                    htSubject, htTo, htUserFields, htXIpro);

  TIpHeaderInfo = record
    FieldType   : TIpHeaderTypes;
    FieldString : string;
  end;

const
  IpMaxHeaders = 24;

  IpHeaderXRef : array [0..IpMaxHeaders - 1] of  TIpHeaderInfo =
    ((FieldType : htBCC;               FieldString : 'BCC'),
     (FieldType : htCC;                FieldString : 'CC'),
     (FieldType : htControl;           FieldString : 'Control: '),
     (FieldType : htDate;              FieldString : 'Date'),
     (FieldType : htDispositionNotify; FieldString : 'Disposition-Notification-To'),
     (FieldType : htFollowUp;          FieldString : 'Followup-To: '),
     (FieldType : htFrom;              FieldString : 'From'),
     (FieldType : htInReplyTo;         FieldString : 'In-Reply-To'),
     (FieldType : htKeywords;          FieldString : 'Keywords'),
     (FieldType : htMessageID;         FieldString : 'Message-ID'),
     (FieldType : htNewsgroups;        FieldString : 'Newsgroups'),
     (FieldType : htNNTPPostingHost;   FieldString : 'NNTP-Posting-Host'),
     (FieldType : htOrganization;      FieldString : 'Organization'),
     (FieldType : htPath;              FieldString : 'Path'),
     (FieldType : htPostingHost;       FieldString : 'Posting-Host'),
     (FieldType : htReceived;          FieldString : 'Received'),
     (FieldType : htReferences;        FieldString : 'References'),
     (FieldType : htReplyTo;           FieldString : 'Reply-To'),
     (FieldType : htReturnPath;        FieldString : 'Return-Path'),
     (FieldType : htSender;            FieldString : 'Sender'),
     (FieldType : htSubject;           FieldString : 'Subject'),
     (FieldType : htTo;                FieldString : 'To'),
     (FieldType : htUserFields;        FieldString : 'X-'),
     (FieldType : htXIpro;             FieldString : 'X-Ipro'));

type
  TIpHeaderCollection = class;

  TIpHeaderItem = class (TCollectionItem)
    private
      FCollection  : TIpHeaderCollection;
      FName        : string;
      FNameL       : string;
        { Lower case version of FName. Used to speed up header searches. }
      FProperty    : Boolean;                                          {!!.13}
      FValue       : TStringList;
    protected
      procedure SetName(const Name : string);
      procedure SetValue (v : TStringList);
    public
      constructor Create (Collection : TCollection); override;
      destructor Destroy; override;
    published
      property Collection : TIpHeaderCollection
               read FCollection write FCollection;
      property Name : string read FName write SetName;
      property NameL : string read FNameL;
        { Lower case version of Name property. }
      property IsProperty : Boolean read FProperty write FProperty;    {!!.13}
        { Set to True if this header is exposed via an iPRO property. }{!!.13}
      property Value : TStringList read FValue write SetValue;
  end;

  TIpHeaderCollection = class (TCollection)
    private
      FOwner : TPersistent;                                              

    protected                                                            
      function GetItem (Index : Integer) : TIpHeaderItem;
      function GetOwner : TPersistent; override;                         
      procedure SetItem (Index : Integer; Value : TIpHeaderItem);        

    public                                                               
      constructor Create (AOwner : TPersistent);                         

      {$IFNDEF VERSION5}                                                 
      procedure Delete (Item : integer);                                 
      {$ENDIF}
      function HasHeader (AName : string) : Integer;
      procedure HeaderByName (AName   : string;
                              Headers : TStringList);
      procedure LoadHeaders (AHeaderList : TStringList;                  
                             Append      : Boolean);                     

      property Items[Index : Integer] : TIpHeaderItem                    
               read GetItem write SetItem;                               
  end;                                                                   
{End !!.12}

  TIpMimeParts = class; { Forwards }

  TIpMimeEntity = class(TPersistent)
  protected {private}
    FProgress                : Byte;
    PrevProgress             : Byte;
    FMimeParts               : TIpMimeParts;
    FParentBoundary          : string;
    FBody                    : TIpAnsiTextStream;
    FEntityName              : string;
    FBoundary                : string;
    FCharacterSet            : string;
    FContentDescription      : string;
    FContentDispositionType  : string;
    FContentID               : string;
    FContentSubtype          : string;
    FContentType             : string;
    FCreationDate            : string;
    FContentTransferEncoding : TIpMimeEncodingMethod;
    FFileName                : string;
    FIsMime                  : Boolean;
    FIsMultipart             : Boolean;
    FModificationDate        : string;
    FMimeVersion             : string;
    FOnCodingProgress        : TIpCodingProgressEvent;
    FOriginalSize            : Longint;
    FParent                  : TIpMimeEntity;
    FReadDate                : string;
    FRelatedType             : string;                                 {!!.02}
    FRelatedSubtype          : string;                                 {!!.02}
    FRelatedStart            : string;                                 {!!.02}
    FRelatedStartInfo        : string;                                 {!!.02}
    FAttachmentCount         : Integer;                                {!!.12}

  protected {methods}
    procedure Clear; virtual;
    procedure ClearBodyLargeAttach(const AttachmentSize : Longint); virtual;  {!!.12}
    function  ContainsSpecialChars(const Value : string) : Boolean;    {!!.14}
    procedure DecodeContentDisposition(const aDisp : string);
    procedure DecodeContentType(const aType : string);
    function  DecodeContentTransferEncoding(const aEncoding : string) :
                                            TIpMimeEncodingMethod;
    procedure DecodeMimeHeaders(RawHeaders : TStringlist);
    procedure DoOnCodingProgress(Count, TotalSize : Longint; var Abort : Boolean);
    procedure EncodeContentDisposition(RawHeaders : TStringList);
    procedure EncodeContentType(RawHeaders : TStringList);
    procedure EncodeContentTransferEncoding(RawHeaders : TStringList);
    procedure EncodeMimeHeaders(RawHeaders : TStringlist);
    procedure OctetStreamToHextetStream(InStream : TStream; OutStream : TIpAnsiTextStream;
                                        const Table; PadChar, Delim : AnsiChar);
    procedure Decode8Bit(OutStream : TStream);
    procedure DecodeBase64(OutStream : TStream);
    procedure DecodeBinHex(OutStream : TStream);
    procedure DecodeQuoted(OutStream : TStream);
    procedure DecodeUUEncode(OutStream : TStream);
    procedure Encode8Bit(InStream : TStream);
    procedure EncodeBase64(InStream : TStream);
    procedure EncodeBinHex(InStream : TStream; const aFileName : string);
    procedure EncodeQuoted(InStream : TStream);
    procedure EncodeUUEncode(InStream : TStream; const aFileName : string);
    function DecodeEntity(InStream : TIpAnsiTextStream) : string;
    function DecodeEntityAsAttachment(InStream : TIpAnsiTextStream) : string;  {!!.01}
    function EncodeEntity(OutStream : TIpAnsiTextStream) : string;
    procedure ReadBody(InStream : TIpAnsiTextStream; const StartLine : string); {!!.12}

  protected {properties}
    property OnCodingProgress : TIpCodingProgressEvent
      read FOnCodingProgress write FOnCodingProgress;

  public {methods}
    constructor Create(ParentEntity : TIpMimeEntity); virtual;
    destructor  Destroy; override;
    procedure ClearBody;
    procedure EncodeBodyFile(const InFile : string);
    procedure EncodeBodyStream(InStream : TStream; const aFileName : string);
    procedure EncodeBodyStrings(InStrings : TStrings; const aFileName : string);
    procedure ExtractBodyFile(const OutFile : string);
    procedure ExtractBodyStream(OutStream : TStream);
    procedure ExtractBodyStrings(OutStrings : TStrings);
    function FindNestedMimePart(const aType, aSubType, aContentID : string) : TIpMimeEntity; {!!.02}
    function  GetMimePart(const aType, aSubType, aContentID : string;
                              CanCreate : Boolean) : TIpMimeEntity;
    function  NewMimePart : TIpMimeEntity;

    property AttachmentCount : Integer read FAttachmentCount;          {!!.12}

  public {properties}
    property Body : TIpAnsiTextStream
      read FBody;

    property Boundary : string
      read FBoundary write FBoundary;

    property CharacterSet : string
      read FCharacterSet write FCharacterSet;

    property ContentDescription : string
      read FContentDescription write FContentDescription;

    property ContentDispositionType : string
      read FContentDispositionType write FContentDispositionType;

    property ContentID : string
      read FContentID write FContentID;

    property ContentSubtype : string
      read FContentSubtype write FContentSubtype;

    property ContentTransferEncoding : TIpMimeEncodingMethod
      read FContentTransferEncoding write FContentTransferEncoding;

    property ContentType : string
      read FContentType write FContentType;

    property CreationDate : string
      read FCreationDate write FCreationDate;

    property EntityName : string
      read FEntityName write FEntityName;

    property FileName : string
      read FFileName write FFileName;

    property IsMime : Boolean
      read FIsMime;

    property IsMultipart : Boolean
      read FIsMultipart;

    property MimeParts : TIpMimeParts
      read FMimeParts;

    property MimeVersion : string
      read FMimeVersion write FMimeVersion;

    property ModificationDate : string
      read FModificationDate write FModificationDate;

    property OriginalSize : Longint
      read FOriginalSize write FOriginalSize;

    property Parent : TIpMimeEntity
      read FParent;

    property ReadDate : string
      read FReadDate write FReadDate;

    property RelatedStart : string                                   {!!.02}
      read FRelatedStart write FRelatedStart;

    property RelatedStartInfo : string                               {!!.02}
      read FRelatedStartInfo write FRelatedStartInfo;

    property RelatedSubtype : string                                 {!!.02}
      read FRelatedSubtype write FRelatedSubtype;

    property RelatedType : string                                    {!!.02}
      read FRelatedType write FRelatedType;

  end;


{ TIpMimeParts }
  TIpMimeParts = class
  protected {private}
    Entitys : TList;
    function GetCount : Integer;
    function GetPart(aIndex : Integer) : TIpMimeEntity;
  public {methods}
    constructor Create;
    destructor  Destroy; override;
    function Add(aEntity : TIpMimeEntity) : Integer;
    function Remove(aEntity : TIpMimeEntity) : Integer;
    procedure Clear;
    procedure Delete(aIndex : Integer);
    function IndexOf(aEntity : TIpMimeEntity) : Integer;
  public {properties}
    property Count : Integer
      read GetCount;
    property Parts[aIndex : Integer] : TIpMimeEntity
      read GetPart; default;
  end;


{ TIpMessage }
type
  TIpMessage = class(TIpMimeEntity)
  protected {private}
    MsgStream : TIpAnsiTextStream;

  protected {property variables}
    FBCC             : TStringList;
    FCC              : TStringList;
    FDate            : string;
    FFrom            : string;
    FInReplyTo       : string;
    FKeywords        : string;
    FFollowupTo      : string;                                           {!!.12}
    FControl         : string;                                           {!!.12}
    FMessageID       : string;
    FMessageTag      : Integer;
    FNewsgroups      : TStringList;
    FNNTPPostingHost : string;
    FOrganization    : string;
    FPath            : TStringList;
    FPostingHost     : string;
    FReceived        : TStringList;
    FRecipients      : TStringList;
    FReferences      : TStringList;
    FReplyTo         : string;
    FReturnPath      : string;
    FSender          : string;
    FSubject         : string;
    FUserFields      : TStringList;
    FHeaders         : TIpHeaderCollection;                              {!!.12}
    FDispositionNotify: string;

  protected {methods}
    procedure CheckAllHeaders;                                           {!!.12}
    procedure CheckHeaderType (HeaderInfo : TIpHeaderItem;               {!!.12}
                               HeaderType : TIpHeaderTypes);             {!!.12}
    procedure Clear; override;
    procedure NewMessageStream;
    function  GetPosition : Longint;
    function  GetSize : Longint;
    procedure SetPosition(Value : Longint);
    procedure SetBCC(const Value: TStringList);
    procedure SetCC(const Value: TStringList);
    procedure SetNewsgroups(const Value: TStringList);
    procedure SetPath(const Value: TStringList);
    procedure SetReceived(const Value: TStringList);
    procedure SetRecipients(const Value: TStringList);
    procedure SetReferences(const Value: TStringlist);
    procedure SetUserFields(const Value: TStringList);

  public {methods}
    constructor CreateMessage; virtual;
    destructor  Destroy; override;

    procedure AddDefaultAttachment(const aFileName : string);          {!!.02}
    procedure AddDefaultAttachmentAs (const aFileName      : string;   {!!.12}
                                      const AttachmentName : string);  {!!.12}
    procedure Assign(Source : TPersistent); override;
    function  AtEndOfStream : Boolean;
    procedure DecodeMessage; virtual;
    procedure EncodeMessage; virtual;
    function  GetBodyHtml(CanCreate : Boolean) : TIpMimeEntity;
    function  GetBodyPlain(CanCreate : Boolean) : TIpMimeEntity;
    procedure LoadFromFile(const aFileName : string);
    procedure LoadFromStream(aStream : TStream);                       {!!.12}
    procedure NewMessage;
    function  ReadLine : string;
    function  ReadLineCRLF : string;
    procedure SaveToFile(const aFileName : string);
    procedure SaveToStream(Stream: TStream);                           {!!.12}
    procedure SetHeaders(Headers : TIpHeaderCollection);               {!!.12}
    procedure WriteLine(const aSt : string);

  public {properties}
    property BCC : TStringList
      read FBCC write SetBCC;                                          {!!.01}

    property CC : TStringList
      read FCC write SetCC;                                            {!!.01}

    property Control : string                                          {!!.12}
      read FControl write FControl;                                    {!!.12}

    property Date : string
      read FDate write FDate;

    property DispositionNotification : string                          {!!.12}
      read FDispositionNotify write FDispositionNotify;                {!!.12}

    property FollowupTo : String                                       {!!.12}
      read FFollowupTo Write FFollowupTo;                              {!!.12}

    property From : string
      read FFrom write FFrom;

    property Headers : TIpHeaderCollection                             {!!.12}
             read FHeaders write SetHeaders;                           {!!.12}

    property InReplyTo : string
      read FInReplyTo write FInReplyTo;

    property Keywords : string
      read FKeywords write FKeywords;

    property MessageID : string
      read FMessageID write FMessageID;

    property MessageStream : TIpAnsiTextStream                         {!!.03}
      read MsgStream;                                                  {!!.03}

    property MessageTag : Integer
      read FMessageTag write FMessageTag;

    property Newsgroups : TStringList
      read FNewsgroups write SetNewsgroups;                            {!!.01}

    property NNTPPostingHost : string
      read FNNTPPostingHost write FNNTPPostingHost;

    property Organization : string
      read FOrganization write FOrganization;

    property Path : TStringList
      read FPath write SetPath;                                        {!!.01}

    property Position : Longint
      read GetPosition write SetPosition;

    property PostingHost : string
      read FPostingHost write FPostingHost;

    property Received : TStringList
      read FReceived write SetReceived;                                {!!.01}

    property Recipients : TStringList
      read FRecipients write SetRecipients;                            {!!.01}

    property References : TStringlist
      read FReferences write SetReferences;                            {!!.01}

    property ReplyTo : string
      read FReplyTo write FReplyTo;

    property ReturnPath : string
      read FReturnPath write FReturnPath;

    property Sender : string
      read FSender write FSender;

    property Size : Longint
      read GetSize;

    property Subject : string
      read FSubject write FSubject;

    property UserFields : TStringList
      read FUserFields write SetUserFields;                            {!!.01}

  end;


{ TIpMailMessage}
type
  TIpMailMessage = class(TIpMessage)
  published {properties}
    property BCC;
    property CC;
    property ContentDescription;
    property ContentTransferEncoding;
    property ContentType;
    property Date;
    property From;
    property Keywords;
    property MailTo : TStringList
      read FRecipients write SetRecipients;                            {!!.01}
    property OnCodingProgress;
    property References;
    property ReplyTo;
    property Sender;
    property Subject;
    property UserFields;
end;


{ TIpNewsArticle }
type
  TIpNewsArticle = class(TIpMessage)
  published {properties}
    property ContentDescription;
    property ContentTransferEncoding;
    property ContentType;
    property Date;
    property From;
    property Keywords;
    property Newsgroups;
    property NNTPPostingHost;
    property OnCodingProgress;
    property Path;
    property References;
    property ReplyTo;
    property Sender;
    property Subject;
    property UserFields;
end;


{ TIpFormDataEntity }
type
  TIpFormDataEntity = class(TIpMimeEntity)
  protected
    FFilesEntity : TIpMimeEntity;
  public {methods}
    constructor Create(ParentEntity : TIpMimeEntity); override;
    destructor  Destroy; override;
    procedure AddFormData(const aName, aText : string);
    procedure AddFile(const aFileName, aContentType, aSubtype : string;
                      aEncoding : TIpMimeEncodingMethod);
    procedure SaveToStream(aStream : TStream);
  end;

 {$IFNDEF IP_LAZARUS}
 { dummy class so this unit will be added to the uses clause when an }
 { IpPop3Client, IpSmtpClient or IpNntpClient component is dropped on the form }
 (*** //JMN
 TIpCustomEmailClass = class(TIpCustomClient)
 end;
 **)
 {$ENDIF}

function IpBase64EncodeString(const InStr: string): string;       {!!.02}{!!.03}

{Begin !!.12}
const
  IpLgAttachSizeBoundry = 5 * 1024 * 1024;
    { Attachments over this size will be encoded using a TIpMemMapStream for
      greatly improved performance. This boundary also applies to the final
      encoding of messages with large attachments. }

implementation

const
  { standard headers }
  strBCC               = 'BCC: ';
  strCC                = 'CC: ';
  strDate              = 'Date: ';
  strDispositionNotify = 'Disposition-Notification-To: ';
  strFrom              = 'From: ';
  strInReplyTo         = 'In-Reply-To: ';
  strKeywords          = 'Keywords: ';
  strMessageID         = 'Message-ID: ';
  strNewsgroups        = 'Newsgroups: ';
  strNNTPPostingHost   = 'NNTP-Posting-Host: ';
  strOrganization      = 'Organization: ';
  strPath              = 'Path: ';
  strPostingHost       = 'Posting-Host: ';
  strReceived          = 'Received: ';
  strReferences        = 'References: ';
  strReplyTo           = 'Reply-To: ';
  strReturnPath        = 'Return-Path: ';
  strSender            = 'Sender: ';
  strSubject           = 'Subject: ';
  strTo                = 'To: ';
  strUserFields        = 'X-';
  strXIpro             = 'X-Ipro: ';
  strFollowUp          = 'Followup-To: ';                               {!!.12}
  strControl           = 'Control: ';                                   {!!.12}

{Begin !!.13}
  IpMimeHeaders : array [0..5] of string =
    { List of MIME headers that must be marked as public properties in
      the message's Headers collection. Marking them as a public property
      prevents them from being written out twice if the message is saved
      to a file or stream. }
    (
      'Content-Type',
      'MIME-Version',
      'Content-Transfer-Encoding',
      'Content-Description',
      'Content-ID',
      'Content-Disposition'
    );
{End !!.13}

  { MIME headers }
  strMimeVersion             = 'MIME-Version: ';
  strContent                 = 'Content-';
  strContentBase             = strContent + 'Base: ';
  strContentDescription      = strContent + 'Description: ';
  strContentDisposition      = strContent + 'Disposition: ';
  strContentID               = strContent + 'ID: ';
  strContentLanguage         = strContent + 'Language: ';
  strContentLocation         = strContent + 'Location: ';
  strContentTransferEncoding = strContent + 'Transfer-Encoding: ';
  strContentType             = strContent + 'Type: ';

  { MIME content types }
  strApplication = 'application';
  strAudio       = 'audio';
  strFiles       = 'files';
  strFormData    = 'form-data';
  strImage       = 'image';
  strMessage     = 'message';
  strMultiPart   = 'multipart';
  strText        = 'text';
  strVideo       = 'video';

  { MIME content subtypes and parameters }
  strBoundary    = 'boundary=';
  strCharSet     = 'charset=';
  strMixed       = 'mixed';
  strName        = 'name=';
  strPlain       = 'plain';
  strHTML        = 'html';
  strOctetStream = 'octet-stream';
  strAlternative = 'alternative';
  strRelated     = 'related';                                        {!!.02}

  { MIME content disposition parameters }
  strAttachment       = 'attachment';
  strInline           = 'inline';
  strCreationDate     = 'creation-date=';
  strFilename         = 'filename=';
  strModificationDate = 'modification-date=';
  strReadDate         = 'read-date=';
  strStart            = 'start=';                                    {!!.02}
  strStartInfo        = 'start-info=';                               {!!.02}
  strSize             = 'size=';
  strType             = 'type=';                                     {!!.02}


  { MIME encoding methods }
  str7Bit     = '7bit';
  str8Bit     = '8bit';
  strBase64   = 'base64';
  strBinary   = 'binary';
  strBinHex   = 'binhex';
  strQuoted   = 'quoted-printable';
  strUUEncode = 'uuencoded';


  { default MIME content type information }
{$I IPDEFCT.INC}

type
  TIp6BitTable = array[0..63] of AnsiChar;

const {- BinHex encoding table }
  IpBinHexTable : TIp6BitTable = (
    '!', '"', '#', '$', '%', '&', '''', '(',
    ')', '*', '+', ',', '-', '0', '1',  '2',
    '3', '4', '5', '6', '8', '9', '@',  'A',
    'B', 'C', 'D', 'E', 'F', 'G', 'H',  'I',
    'J', 'K', 'L', 'M', 'N', 'P', 'Q',  'R',
    'S', 'T', 'U', 'V', 'X', 'Y', 'Z',  '[',
    '`', 'a', 'b', 'c', 'd', 'e', 'f',  'h',
    'i', 'j', 'k', 'l', 'm', 'p', 'q',  'r');

const {-BinHex decoding table }
  IpHexBinTable : array[33..114] of Byte = (
    $00, $01, $02, $03, $04, $05, $06, $07,
    $08, $09, $0A, $0B, $0C, $FF, $FF, $0D,
    $0E, $0F, $10, $11, $12, $13, $FF, $14,
    $15, $FF, $FF, $FF, $FF, $FF, $FF, $16,
    $17, $18, $19, $1A, $1B, $1C, $1D, $1E,
    $1F, $20, $21, $22, $23, $24, $FF, $25,
    $26, $27, $28, $29, $2A, $2B, $FF, $2C,
    $2D, $2E, $2F, $FF, $FF, $FF, $FF, $30,
    $31, $32, $33, $34, $35, $36, $FF, $37,
    $38, $39, $3A, $3B, $3C, $FF, $FF, $3D,
    $3E, $3F);

const { Base64 encoding table }
  Ip64Table : TIp6BitTable = (
    #065, #066, #067, #068, #069, #070, #071, #072,
    #073, #074, #075, #076, #077, #078, #079, #080,
    #081, #082, #083, #084, #085, #086, #087, #088,
    #089, #090, #097, #098, #099, #100, #101, #102,
    #103, #104, #105, #106, #107, #108, #109, #110,
    #111, #112, #113, #114, #115, #116, #117, #118,
    #119, #120, #121, #122, #048, #049, #050, #051,
    #052, #053, #054, #055, #056, #057, #043, #047);

const { Base64 decoding table }
  IpD64Table : array[#43..#122] of Byte = (                          {!!.12}
    $3E, $7F, $7F, $7F, $3F, $34, $35, $36,
    $37, $38, $39, $3A, $3B, $3C, $3D, $7F,
    $7F, $7F, $7F, $7F, $7F, $7F, $00, $01,
    $02, $03, $04, $05, $06, $07, $08, $09,
    $0A, $0B, $0C, $0D, $0E, $0F, $10, $11,
    $12, $13, $14, $15, $16, $17, $18, $19,
    $7F, $7F, $7F, $7F, $7F, $7F, $1A, $1B,
    $1C, $1D, $1E, $1F, $20, $21, $22, $23,
    $24, $25, $26, $27, $28, $29, $2A, $2B,
    $2C, $2D, $2E, $2F, $30, $31, $32, $33);

const { UUEncode encoding table }
  IpUUTable : TIp6BitTable = (
    #96, #33, #34, #35, #36, #37, #38, #39,
    #40, #41, #42, #43, #44, #45, #46, #47,
    #48, #49, #50, #51, #52, #53, #54, #55,
    #56, #57, #58, #59, #60, #61, #62, #63,
    #64, #65, #66, #67, #68, #69, #70, #71,
    #72, #73, #74, #75, #76, #77, #78, #79,
    #80, #81, #82, #83, #84, #85, #86, #87,
    #88, #89, #90, #91, #92, #93, #94, #95);

const
  HexDigits : array[0..$F] of AnsiChar = '0123456789ABCDEF';
  RLEChar : Byte = $90;
  BinHexFileType : array[0..3] of Byte = ($49, $42, $4D, $3F);  { "IBM?" }
  CRLF = #13#10;
  MaxLine = 1000;                                                       {!!.12}
  MaxLineEncode = 77;                                                   {!!.13}
    { Maximum line length for QuotablePrintable & Base64 encoding. }    {!!.13}

type
  BinHexHeader = packed record
    Version  : Byte;
    FileType : array[0..3] of Byte;
    Creator  : array[0..3] of Byte;
    Flags    : Word;
    DFLong   : Longint;
    RFLong   : Longint;
  end;

function IsSameString (Str1          : string;                           {!!.12}
                       Str2          : string;                           {!!.12}
                       CaseSensitive : Boolean) : Boolean;               {!!.12}
begin                                                                    {!!.12}
  if CaseSensitive then                                                  {!!.12}
    Result := (Str1 = Str2)                                              {!!.12}
  else                                                                   {!!.12}
    Result := StrIComp (PChar (Str1), PChar (Str2)) = 0;                 {!!.12}
end;                                                                     {!!.12}

{ Parse string into string list }
procedure Parse(const Line : string; Delim : AnsiChar; var List : TStringList);
var
  iPos, jPos : Integer;
  Term : string;
begin
  iPos := 1;
  jPos := IpUtils.CharPos(Delim, Line);
  while (jPos > 0) do begin
    Term := Copy(Line, iPos, jPos - iPos);                           {!!.02}
    if (Term <> '') then
      List.Add(Trim(Term));
    iPos := jPos + 1;
    jPos := IpUtils.CharPosIdx(Delim, Line, iPos);
  end;
  if (iPos < Length(Line)) then
     List.Add(Trim(Copy(Line, iPos, Length(Line))));
end;

{ Return a particular parameter from a parsed header parameter list }
procedure DecodeSingleParameter(const ParamName : string;
                                RawParams : TStringList;
                                var ParamFieldStr : string);
var
  S : string;
  i, j : Integer;
begin
  ParamFieldStr := '';
  {find the line containing the parameter field name}
  for i := 1 to RawParams.Count do begin
    S := RawParams[i-1];
    if StrLIComp(PChar(ParamName), PChar(S), Length(ParamName)) = 0 then begin
      {strip off the parameter field name and remove quotes }
      ParamFieldStr := Copy(S, Length(ParamName) + 1, Length(S));
      j := IpUtils.CharPos('"', ParamFieldStr);
      while (j > 0) do begin
        Delete(ParamFieldStr, j, 1);
        j := IpUtils.CharPos('"', ParamFieldStr);
      end;
      Break;
    end;
  end;
end;

{ Return a particular header as string }
procedure DecodeSingleHeader(const HeaderName : string;
                             RawHeaders : TStringList;
                             var HeaderFieldStr : string);
var
  S, S2 : string;
  i, j : Integer;
begin
  HeaderFieldStr := '';
  {find the line containing the header field name}
  for i := 1 to RawHeaders.Count do begin
    S := RawHeaders[i-1];
    if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
      {strip off the header field name}
      S := Copy(S, Length(HeaderName) + 1, Length(S));
      {unfold the header if continued on more than one line}
      if (i < RawHeaders.Count) then
        for j := i to Pred(RawHeaders.Count) do begin
          S2 := RawHeaders[j];
          if (Length(S2) > 0) and (S2[1] <> #09) and (S2[1] <> ' ') then
            Break
          else
            S := S + S2;
        end;
      HeaderFieldStr := S;
      Break;
    end;
  end;
end;

{ Return a particular header as string list }
(*procedure DecodeListHeader(const HeaderName : string;
                           RawHeaders, HeaderFieldList : TStringList);
var
  S : string;
  i, j : Integer;
begin
  {find the line containing the header field name}
  for i := 1 to RawHeaders.Count do begin
    S := RawHeaders[i-1];
    if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
      {strip off the header field name}
      HeaderFieldList.Add(Copy(S, Length(HeaderName) + 1, Length(S)));
      {unfold the header if continued on more than one line}
      if (i < RawHeaders.Count) then
        for j := i to Pred(RawHeaders.Count) do begin
          S := RawHeaders[j];
          if (Length(S) > 0) and (S[1] <> #09) and (S[1] <> ' ') then
            Break
          else
            HeaderFieldList.Add(S);
        end;
      Break;
    end;
  end;
end;*)

{ Return multiple instance headers as string list }
(*procedure DecodeMultiHeader(const HeaderName : string;
                            RawHeaders, HeaderFieldList : TStringList);

var
  S, S2 : string;
  i, j : Integer;
begin
  {find the next line containing the header field name}
  for i := 1 to RawHeaders.Count do begin
    S := RawHeaders[i-1];
    if StrLIComp(PChar(HeaderName), PChar(S), Length(HeaderName)) = 0 then begin
      if HeaderName <> strUserFields then begin                         {!!.11}
        {strip off the header field name}
        S := Copy(S, Length(HeaderName) + 1, Length(S));
        {unfold the header if continued on more than one line}
        if (i < RawHeaders.Count) then
          for j := i to Pred(RawHeaders.Count) do begin
            S2 := RawHeaders[j];
            if (Length(S2) > 0) and (S2[1] <> #09) and (S2[1] <> ' ') then
              Break
            else
              S := S + S2;
          end;
      end;                                                              {!!.11}
      HeaderFieldList.Add(S);
    end;
  end;
end;*)

{ Add header string to raw headers }
procedure EncodeSingleHeader(const HeaderName : string;
                             RawHeaders : TStringList;
                             HeaderFieldStr : string);
begin
  if (HeaderFieldStr <> '') then
    RawHeaders.Add(HeaderName + HeaderFieldStr);
end;

{ Unfold multiple line header and add to raw headers }
procedure EncodeListHeader(const HeaderName : string;
                           RawHeaders, HeaderFieldList : TStringList;
                           const Delim : string;
                           Fold : Boolean);
var
  S : string;
  i : Integer;
begin
  if (HeaderFieldList.Count > 0) then begin
    S := HeaderName;
    for i := 0 to Pred(HeaderFieldList.Count) do begin
      if (Length(S + HeaderFieldList[i]) > MaxLine) then begin
        RawHeaders.Add(S);
        S := #09;
      end;
      S := S + HeaderFieldList[i];
      if (i < HeaderFieldList.Count - 1) and (S <> '') then begin
        S := S + Delim;                                                {!!.14}
        if Fold then begin
          RawHeaders.Add(S);
          S := #09;
        end;
      end;
    end;
    RawHeaders.Add(S);
  end;
end;

{ Add multiple instance header to raw headers }
procedure EncodeMultiHeader(const HeaderName : string;
                            RawHeaders, HeaderFieldList : TStringList;
                            Delim : AnsiChar;
                            Fold : Boolean);
var
  i, j : Integer;
  SL : TStringList;
  S : string;
begin
  if (HeaderFieldList.Count > 0) then
    for j := 1 to HeaderFieldList.Count do begin
      if not Fold then
        RawHeaders.Add(HeaderName + HeaderFieldList[j-1])
      else begin
        SL := TStringList.Create;
        try
          Parse(HeaderFieldList[j-1], Delim, SL);
          S := HeaderName;
          for i := 1 to SL.Count do begin
            S := S + SL[i-1];
            if (i < SL.Count) and (S <> '') then begin
{Begin !!.13}
              RawHeaders.Add(S);
              S := Delim;
{End !!.13}
            end;
          end;
        finally
          SL.Free;
        end;
        RawHeaders.Add(S);
      end;
    end;
end;

{ Generate "unique" boundary string }
function GenerateBoundary : string;
var
  Temp : TDateTime;
begin
  Temp := Now;
  Randomize;
  Result := '_NextPart_' + IntToHex(Trunc(Temp), 8) + '-' +
    IntToHex(Trunc(Frac(Temp) * 10000), 8) + '-' +
    IntToHex(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;

{Begin !!.12}
{ TIpHeaderItem ****************************************************** }

constructor TIpHeaderItem.Create (Collection : TCollection);
begin
  inherited Create (Collection);
  FCollection := TIpHeaderCollection.Create (
                     TIpHeaderCollection(Collection).FOwner);

  FValue := TStringList.Create;
  FName  := '';
  FProperty := False;                                                  {!!.13}
end;                                                                     

destructor TIpHeaderItem.Destroy;                                        
begin                                                                    
  FCollection.Free;                                                      
  FCollection := nil;                                                    

  FValue.Free;                                                           
  FValue := nil;                                                         

  inherited Destroy;                                                     
end;                                                                     

procedure TIpHeaderItem.SetName(const Name : string);
begin
  FName := Name;
  FNameL := LowerCase(Name);
end;

procedure TIpHeaderItem.SetValue (v : TStringList);                      
begin                                                                    
  FValue.Assign (v);                                                     
end;                                                                     

{ TIpHeaderCollection ************************************************ } 

constructor TIpHeaderCollection.Create(AOwner : TPersistent);            
begin                                                                    
  inherited Create (TIpHeaderItem);                                      
  FOwner := AOwner;                                                      
end;                                                                     

{$IFNDEF VERSION5}                                                       
procedure TIpHeaderCollection.Delete(Item: integer);                     
begin                                                                    
  GetItem(Item).Free;                                                    
end;                                                                     
{$ENDIF}                                                                 

function TIpHeaderCollection.GetItem (Index : Integer) : TIpHeaderItem;  
begin                                                                    
  Result := TIpHeaderItem (inherited GetItem (Index));                   
end;                                                                     

function TIpHeaderCollection.GetOwner : TPersistent;                     
begin                                                                    
  Result := FOwner;                                                      
end;                                                                     

function TIpHeaderCollection.HasHeader (AName : string) : Integer;
var                                                                      
  i : Integer;                                                           
begin                                                                    
  Result := -1;                                                          
  AName := LowerCase(AName);
  for i := 0 to Count - 1 do
    if Items[i].NameL = AName then begin                      
      Result := i;                                                       
      Break;                                                             
    end;                                                                 
end;                                                                     

procedure TIpHeaderCollection.HeaderByName (AName   : string;            
                                            Headers : TStringList);      
var
  HeaderPos : Integer;                                                   
begin                                                                    
  Headers.Clear;                                                         
  HeaderPos := HasHeader (AName);                                        
  if HeaderPos >= 0 then                                                 
    Headers.Assign (Items[HeaderPos].Value);                             
end;                                                                     

procedure TIpHeaderCollection.LoadHeaders (AHeaderList : TStringList;
                                           Append      : Boolean);
var
  CurPos : Integer;

  function ExtractHeaderName (const AName : string) : string;
  {!!.15 - replaced local variable i with inx in order to avoid confusion with
    variable i in parent routine. }
  var
    inx     : Integer;
    NameLen : Integer;
  begin
    Result := '';
    CurPos := 0;

    inx := 0;
    NameLen := Length (AName);
    while (inx < NameLen) and (AName[inx + 1] <> ':') and
          (AName[inx + 1] >= #33) and (AName[inx + 1] <= #126) do
      Inc (inx);
    if (inx > 0) then
      Result := Copy (AName, 1, inx);
    CurPos := inx + 2;
  end;

  function IsWrappedLine (AHeaderList : TStringList;
                          LineToCheck : Integer) : Boolean;
  begin
    if LineToCheck < AHeaderList.Count then begin
      if Length (AHeaderList[LineToCheck]) > 0 then begin
        if (AHeaderList[LineToCheck][1] = ' ') or
           (AHeaderList[LineToCheck][1] = #09) then
          Result := True
        else
          Result := False;
      end else
        Result := False;
    end else
      Result := False;
  end;

  procedure GetFieldValue (    AHeaderList : TStringList;
                           var CurLine     : Integer;
                           var NewField    : TIpHeaderItem);
  var
    WorkLine : string;
    LineLen  : Integer;

  begin
    if CurLine >= AHeaderList.Count then
      Exit;
    LineLen  := Length (AHeaderList[CurLine]);
    while (CurPos < LineLen) and
          ((AHeaderList[CurLine][CurPos] = ' ') or
           (AHeaderList[CurLine][CurPos] = #09)) do
      Inc (CurPos);
    WorkLine := Copy (AHeaderList[CurLine],
                      CurPos, LineLen - CurPos + 1);
{Begin !!.13}
    Inc(CurLine);

    while IsWrappedLine (AHeaderList, CurLine) do begin
      WorkLine := WorkLine + #9 + Trim(AHeaderList[CurLine]);
      Inc(CurLine);
    end;
    NewField.Value.Add (Trim (WorkLine));
{End !!.13}
  end;

var                                                                      
  i          : Integer;                                                  
  HeaderName : string;                                                   
  NewHeader  : TIpHeaderItem;                                            
begin                                                                    
  if not Append then                                                     
    Clear;

  i := 0;                                                                
  while i < AHeaderList.Count do begin                                   
    HeaderName := ExtractHeaderName (AHeaderList[i]);                    
    if HeaderName <> '' then begin                                       
      NewHeader := TIpHeaderItem (Add);                                  
      NewHeader.Name := HeaderName;                                      
      GetFieldValue (AHeaderList, i, NewHeader);
{Begin !!.15}
    end
    else
      Inc(i);
{End !!.15}
  end;
end;                                                                     

procedure TIpHeaderCollection.SetItem (Index : Integer;                  
                                       Value : TIpHeaderItem);           
begin                                                                    
  inherited SetItem (Index, Value);                                      
end;
{End !!.12}

{ TIpMimeParts }
constructor TIpMimeParts.Create;
begin
  inherited Create;
  Entitys := TList.Create;
end;

destructor TIpMimeParts.Destroy;
begin
  Clear;
  Entitys.Free;
  inherited Destroy;
end;

{ Add Mime block to list }
function TIpMimeParts.Add(aEntity : TIpMimeEntity) : Integer;
begin
  Result := Entitys.Add(aEntity);
end;

{ Clear list }
procedure TIpMimeParts.Clear;
var
  i : Integer;
begin
  for i := Pred(Entitys.Count) downto 0 do
    Delete(i);
end;

{ Delete block from list }
procedure TIpMimeParts.Delete(aIndex : Integer);
begin
  if (aIndex >= 0) and (aIndex < Entitys.Count) then begin
    TIpMimeEntity(Entitys[aIndex]).Free;
  end;
end;

{ Remove block from list }
function TIpMimeParts.Remove(aEntity : TIpMimeEntity) : Integer;
begin
  Result := Entitys.Remove(Pointer(aEntity));
end;

{ Count property read access method }
function TIpMimeParts.GetCount : Integer;
begin
  Result := Entitys.Count;
end;

{ Parts property read access method }
function TIpMimeParts.GetPart(aIndex : Integer) : TIpMimeEntity;
begin
  if (aIndex >= 0) and (aIndex < Entitys.Count) then
    Result := TIpMimeEntity(Entitys[aIndex])
  else
    Result := nil;
end;

{ Returns list index of specified Mime block }
function TIpMimeParts.IndexOf(aEntity : TIpMimeEntity) : Integer;
begin
  Result := Entitys.IndexOf(aEntity);
end;


{ TIpMimeEntity }
constructor TIpMimeEntity.Create(ParentEntity : TIpMimeEntity);
begin
  inherited Create;
  FBody := TIpAnsiTextStream.CreateEmpty;
  FBody.Stream := TMemoryStream.Create;
  FMimeParts := TIpMimeParts.Create;
  FParent := ParentEntity;
  if (FParent <> nil) then
    FParentBoundary := FParent.Boundary;
end;

destructor TIpMimeEntity.Destroy;
begin
  FMimeParts.Free;
  FBody.FreeStream;
  FBody.Free;
  if (FParent <> nil) then
    FParent.MimeParts.Remove(Self);
  inherited Destroy;
end;

{ Clear Body property }
procedure TIpMimeEntity.ClearBody;
begin
  FBody.FreeStream;
  FBody.Stream := TMemoryStream.Create;
end;

{Begin !!.12}
{ Clear Body property in preparation for large attachment }
procedure TIpMimeEntity.ClearBodyLargeAttach(const AttachmentSize : Longint);
var
  FileName : string;
  Strm : TIpMemMapStream;
begin
  FBody.FreeStream;
  FileName := GetTemporaryFile(GetTemporaryPath);
  if FileExistsUTF8(FileName) then
    DeleteFileUTF8(FileName);
  Strm := TIpMemMapStream.Create(FileName, False, True);
  Strm.Size := Trunc(AttachmentSize * 1.3695);
  Strm.Open;
  FBody.Stream := Strm;
end;
{End !!.12}

{ Clear all properties }
procedure TIpMimeEntity.Clear;
begin
  ClearBody;
  FMimeParts.Clear;
  FBoundary := '';
  FCharacterSet := '';
  FContentDescription := '';
  FContentDispositionType := '';
  FContentID := '';
  FContentSubtype := '';
  FContentType := '';
  FContentTransferEncoding := emUnknown;
  FFileName := '';
  FIsMime := False;
  FIsMultipart := False;
  FMimeVersion := '';
  FEntityName := '';
  FRelatedType := '';                                                {!!.02}
  FRelatedSubtype := '';                                             {!!.02}
  FRelatedStart := '';                                               {!!.02}
  FRelatedStartInfo := '';                                           {!!.02}
end;

{ Build Mime (and nested Mime) block(s) from incoming text stream }
function TIpMimeEntity.DecodeEntity(InStream : TIpAnsiTextStream) : string;
var
  Blk : TIpMimeEntity;
  RawHeaders : TStringList;
  Decoded : Boolean;                                                   {!!.12}
  i,                                                                   {!!.13}
  LeadingBlankLines : Integer;                                         {!!.13}
begin
  Decoded := False;                                                    {!!.12}
  LeadingBlankLines := 0;                                              {!!.13}
  { skip blank lines in front of mime headers or body }
  Result := InStream.ReadLine;
  while (Result = '') and not InStream.AtEndOfStream do begin
    inc(LeadingBlankLines);
    Result := InStream.ReadLine;
  end;

  { decode mime headers if any }
{Begin !!.15}
  if (StrLIComp(PChar(strContent), PChar(Result), Length(strContent)) = 0) or
     (StrLIComp(PChar(strMimeVersion), PChar(Result),
                Length(strMimeVersion)) = 0) then begin
{End !!.15}
    RawHeaders := TStringList.Create;
    try
      repeat
        RawHeaders.Add(Result);
        Result := InStream.ReadLine;
      until (Result = '') or (InStream.AtEndOfStream);
      DecodeMimeHeaders(RawHeaders);
    finally
      RawHeaders.Free;
    end;
    Result := InStream.ReadLine;
    { skip blank lines between mime headers and mime body }
    while (Result = '') and not InStream.AtEndOfStream do
      Result := InStream.ReadLine;
  end;

  { decode body - main loop }
{Begin !!.15}
  if (FParentBoundary <> '') and
     (Result = '--' + FParentBoundary) then
    { The body of this entity is empty & we are now positioned at the boundary
      marker for the next entity. }
    Decoded := True
  else
{End !!.15}
  while not (((FParentBoundary <> '') and                              {!!.12}
              (Result = '--' + FParentBoundary)                        {!!.12}
             ) or InStream.AtEndOfStream) do begin                     {!!.12}
    Decoded := True;
    { check for ending boundary - in which case were done }
    if (FParentBoundary <> '') then
      if Pos('--' + FParentBoundary + '--', Result) = 1 {> 0} then begin
        Result := InStream.ReadLine;
        Exit;
      end;

    { decode any nested mime parts - recursively }
    if IsMultiPart and (Boundary <> '') and                            {!!.03}
      (Pos('--' + Boundary, Result) = 1)  then begin
      Blk := TIpMimeEntity.Create(Self);
      Result := Blk.DecodeEntity(Instream);
      FMimeParts.Add(Blk);
    end else begin
      { read raw text line into body }
      for i := 1 to LeadingBlankLines do                               {!!.13}
        Body.WriteLine('');                                            {!!.13}
      Body.WriteLine(Result);
      Result := InStream.ReadLine;
    end;
    if InStream.AtEndOfStream then break;                              {!!.12}
    LeadingBlankLines := 0;                                            {!!.13}
  end;
{Begin !!.12}
  { If did not find a MIME entity then assume the body is text &
    read it into the Body property. }
  if not Decoded then
    ReadBody(InStream, Result)
  else if (not (Pos('--' + FParentBoundary, Result) = 1)) then
    { If the last line is not a MIME separator then add the last line
      to the Body. }
    Body.WriteLine(Result);
{End !!.12}
end;

{!!.01}
{ Build Mime block as subpart from incoming text stream }
function TIpMimeEntity.DecodeEntityAsAttachment(InStream : TIpAnsiTextStream) : string;
var
  Blk : TIpMimeEntity;
begin
  Blk := TIpMimeEntity.Create(Self);
  Blk.ContentType := FContentType;
  Blk.ContentSubtype := FContentSubtype;
  Blk.ContentDispositionType := FContentDispositionType;
  Blk.ContentDescription := FContentDescription;
  Blk.ContentTransferEncoding := FContentTransferEncoding;
  Blk.CharacterSet := FCharacterSet;
  Blk.CreationDate := FCreationDate;
  Blk.FileName := FFileName;
  Blk.EntityName := FEntityName;
  Blk.FIsMime := True;
  Blk.FIsMultipart := False;
  Blk.ModificationDate := FModificationDate;
  Blk.MimeVersion := FMimeVersion;
  Blk.OriginalSize := FOriginalSize;
  Blk.ReadDate := FReadDate;

  Result := Blk.DecodeEntity(Instream);
  FMimeParts.Add(Blk);
  Body.Position := 0;
end;

{ Decode Content-Disposition header field and sub-fields }
procedure TIpMimeEntity.DecodeContentDisposition(const aDisp : string);
var
  RawParams : TStringList;
  S : string;
begin
  { split up parameters }
  RawParams := TStringList.Create;
  try
    Parse(aDisp, ';', RawParams);

    { decode disposition type and parameters }
    if (RawParams.Count > 0) then begin
      FContentDispositionType := RawParams[0];
      if (RawParams.Count > 1) then begin
        DecodeSingleParameter(strFileName, RawParams, FFileName);
        DecodeSingleParameter(strCreationDate, RawParams, FCreationDate);
        DecodeSingleParameter(strModificationDate, RawParams, FModificationDate);
        DecodeSingleParameter(strReadDate, RawParams, FReadDate);
        DecodeSingleParameter(strSize, RawParams, S);
        FOriginalSize := StrToIntDef(S, 0);
      end;
    end else
      FContentDispositionType := '';
  finally
    RawParams.Free;
  end;
end;

{ Decode Content-Type header field and sub-fields }
procedure TIpMimeEntity.DecodeContentType(const aType : string);
var
  RawParams : TStringList;
  S : string;
  i : Integer;
begin
  { split up parameters }
  RawParams := TStringList.Create;
  try
    Parse(aType, ';', RawParams);

    { decode type and subtype }
    FContentType := '';
    FContentSubType := '';
    if (RawParams.Count > 0) then begin
      S := RawParams[0];
      i := IpUtils.CharPos('/', S);
      if (i > 0) then begin
        FContentType := Copy(S, 1, i - 1);
        FContentSubType := Copy(S, i + 1, Length(S));
      end else
        FContentType := S;
    end;
    FIsMultipart := StrIComp(PChar(FContentType), PChar(strMultipart)) = 0;

    { decode the parameters }
    DecodeSingleParameter(strName, RawParams, FEntityName);
    DecodeSingleParameter(strBoundary, RawParams, FBoundary);
    DecodeSingleParameter(strCharSet, RawParams, FCharacterSet);

    {!!.02}
    { decode multipart/related parameters }
    DecodeSingleParameter(strType, RawParams, S);
    if (S <> '') then begin
      i := IpUtils.CharPos('/', S);
      if (i > 0) then begin
        FRelatedType := Copy(S, 1, i - 1);
        FRelatedSubType := Copy(S, i + 1, Length(S));
      end else
        FRelatedType := S;
      DecodeSingleParameter(strStart, RawParams, FRelatedStart);
      DecodeSingleParameter(strStartInfo, RawParams, FRelatedStartInfo);
    end;
    {!!.02}

  finally
    RawParams.Free;
  end;
end;

{ Decode Content-TranferEncoding header field }
function TIpMimeEntity.DecodeContentTransferEncoding(const aEncoding : string) :
  TIpMimeEncodingMethod;
begin
  if (UpperCase(aEncoding) = UpperCase(str7Bit)) then
    Result := em7bit
  else if (UpperCase(aEncoding) = UpperCase(str8Bit)) then
    Result := em8bit
  else if (UpperCase(aEncoding) = UpperCase(strBase64)) then
    Result := emBase64
  else if (UpperCase(aEncoding) = UpperCase(strBinary)) then
    Result := emBinary
  else if (UpperCase(aEncoding) = UpperCase(strBinHex)) then
    Result := emBinHex
  else if (UpperCase(aEncoding) = UpperCase(strQuoted)) then
    Result := emQuoted
  else if (UpperCase(aEncoding) = UpperCase(strUUEncode)) then
    Result := emUUEncode
  else
    Result := emUnknown;
end;


{ Decode Mime headers from raw header list }
procedure TIpMimeEntity.DecodeMimeHeaders(RawHeaders : TStringList);
var
  S : string;
begin
  { decode content type header }
  DecodeSingleHeader(strContentType, RawHeaders, S);
  if (S <> '') then begin
    FIsMime := True;
    DecodeContentType(S);
    if FIsMultipart and (FBoundary = '') then
      raise EIpBaseException.Create(SNoBoundary);
  end else begin
    FIsMime := False;
    Exit;
  end;

  { decode the others }
  DecodeSingleHeader(strMIMEVersion, RawHeaders, FMimeVersion);
  DecodeSingleHeader(strContentTransferEncoding, RawHeaders, S);
  FContentTransferEncoding := DecodeContentTransferEncoding(S);
  DecodeSingleHeader(strContentDescription, RawHeaders, FContentDescription);
  DecodeSingleHeader(strContentID, RawHeaders, FContentID);
  DecodeSingleHeader(strContentDisposition, RawHeaders, S);
  if (S <> '') then
    DecodeContentDisposition(S);
  if (FContentDispositionType = strAttachment) then                    {!!.12}
    Inc (FParent.FAttachmentCount);                                    {!!.12}{!!.15}
end;

{ Compute attachment coding progress and fire OnCodingProgress event }
procedure TIpMimeEntity.DoOnCodingProgress(Count, TotalSize : Longint;
                                          var Abort : Boolean);
  { IMPORTANT: The progress event must only be fired by the root parent }
begin
  if (Parent = nil) or (Parent = Self) then begin
    FProgress := ((Count*100) div TotalSize);
    if (FProgress > 100) then
      FProgress := 100;
    if (FProgress div 10) = 0 then
      PrevProgress := 0;

    { report progress in 10% increments }
    if ((FProgress div 10) > (PrevProgress div 10)) then begin
      PrevProgress := FProgress;
      if Assigned(FOnCodingProgress) then
        FOnCodingProgress(Self, FProgress, Abort);
    end;
  end else
    Parent.DoOnCodingProgress(Count, TotalSize, Abort);
end;

{ Generate Mime message stream from properties (and nested Mime blocks) }
function TIpMimeEntity.EncodeEntity(OutStream : TIpAnsiTextStream) : string;
var
  i : Integer;
  S : string;
  RawHeaders : TStringList;
  Ch : AnsiChar;
begin
  Result := FParentBoundary;

  { write out mime headers }
  if (Result <> '') then begin
    OutStream.WriteLine('--' + Result);
    RawHeaders := TStringList.Create;
    try
      EncodeMimeHeaders(RawHeaders);
      if (RawHeaders.Count > 0) then
        for i := 0 to Pred(RawHeaders.Count) do
          if (RawHeaders[i] <> '') then
            OutStream.WriteLine(RawHeaders[i]);
      OutStream.WriteLine('');
    finally
      RawHeaders.Free;
    end;
  end;

  // flush to update underlaying memory streams
  Body.Flush;
  { write out mime body }
  if (Body.FastSize > 0) then
  begin
    // presize stream for more speed
    OutStream.Stream.Size := OutStream.Stream.Size + Body.FastSize;
    // use optimal method depending on the source stream to copy the stream
    if Body.Stream is TIpMemMapStream then
      OutStream.Write((Body.Stream as TIpMemMapStream).Memory^, Body.FastSize)
    else   
      if Body.Stream is TMemoryStream then
        OutStream.Write((Body.Stream as TMemoryStream).Memory^, Body.Stream.Size)
      else 
        OutStream.CopyFrom(Body, 0); // copy the entire stream from the beginning

    { make sure the body is properly terminated }                    {!!.01}
    OutStream.Position := OutStream.Size - 1;                        {!!.01}
    TIpBufferedStream(OutStream).ReadChar(Ch);                       {!!.01}
    if ((Ch <> #13) and (Ch <> #10)) then                            {!!.01}
      OutStream.WriteLine('');                                       {!!.01}
  end;

  { encode nested mime parts - recursively }
  if (FMimeParts.Count > 0) then begin
    for i := 0 to Pred(FMimeParts.Count) do
      S := FMimeParts[i].EncodeEntity(OutStream);
    OutStream.WriteLine('--' + S + '--');
  end;
end;

{Begin !!.14}
function TIpMimeEntity.ContainsSpecialChars(const Value : string) : Boolean;
var
  Inx : Integer;
begin
  Result := False;
  for Inx := 1 to Length(Value) do
    if (Ord(Value[Inx]) <= 32) or
       (Value[Inx] in ['(', ')', '<', '>', '@',
                       ',', ';', ':', '\', '"',
                       '/', '[', ']', '?', '=']) then begin
      Result := True;
      Break;
    end; { if }
end;
{End !!.14}

{ Generate Content-Disposition header into raw header list }
procedure TIpMimeEntity.EncodeContentDisposition(RawHeaders : TStringList);
var
  Params : TStringList;
begin
  if (FContentDispositionType = '') then
    Exit;

  Params := TStringList.Create;
  try
    Params.Add(FContentDispositionType);
{Begin !!.14}
    if (FFileName <> '') then begin
      { If the filename contains spaces, control characters, or any of the
        special characters identified in RFC 1521 then wrap the filename in
        quotes.

        Assumption: FFileName length is <= 78 characters. Future enhancement
        is to support RFC 2184. }
      if ContainsSpecialChars(FFileName) then
        Params.Add(strFileName + '"' + FFileName + '"')
      else
        Params.Add(strFileName + FFileName);
    end;  { if }
{End !!.14}
    if (FCreationDate <> '') then
      Params.Add(strCreationDate + FCreationDate);
    if (FModificationDate <> '') then
      Params.Add(strModificationDate + FModificationDate);
    if (FReadDate <> '') then
      Params.Add(strReadDate + FReadDate);
    if (FOriginalSize > 0) then
      Params.Add(strSize + IntToStr(FOriginalSize));
    EncodeListHeader(strContentDisposition, RawHeaders, Params, ';', False);
  finally
    Params.Free;
  end;
end;

{ Generate Content-Type header into raw header list }
procedure TIpMimeEntity.EncodeContentType(RawHeaders : TStringList);
var
  S : string;
  Params : TStringList;
begin
  if (FContentType = '') then
    Exit;

  Params := TStringList.Create;
  try
    S := FContentType;
    if (FContentSubType <> '') then
      S := S + '/' + FContentSubType;
    Params.Add(S);
    if IsMultipart then
      Params.Add(strBoundary + '"' + FBoundary + '"');
    if (FEntityName <> '') then
      Params.Add(strName + '"' + FEntityName + '"');
    if (FCharacterSet <> '') then
      Params.Add(strCharSet + FCharacterSet); {no quotes}

    {!!.02}
    { encode multipart/related parameters }
    if (FRelatedType <> '') then begin
      if (FRelatedSubtype <> '') then
        Params.Add(strType + '"' + FRelatedType + '/' + FRelatedSubtype + '"')
      else
        Params.Add(strType + '"' + FRelatedType + '"');
      if (FRelatedStart <> '') then
        Params.Add(strStart + '"' + FRelatedStart + '"');
      if (FRelatedStartInfo <> '') then
        Params.Add(strStartInfo + '"' + FRelatedStartInfo + '"');
    end;
    {!!.02}

    EncodeListHeader(strContentType, RawHeaders, Params, ';', False);
  finally
    Params.Free;
  end;
end;

{ Generate Content-TranferEncoding header into raw header list }
procedure TIpMimeEntity.EncodeContentTransferEncoding(RawHeaders : TStringList);
begin
  case FContentTransferEncoding of
    em7bit     : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, str7Bit);
    em8bit     : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, str8Bit);
    emBase64   : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBase64);
    emBinary   : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBinary);
    emBinHex   : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strBinHex);
    emQuoted   : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strQuoted);
    emUUEncode : EncodeSingleHeader(strContentTransferEncoding, RawHeaders, strUUEncode);
  end;
end;

{ Generate Mime headers into raw header list }
procedure TIpMimeEntity.EncodeMimeHeaders(RawHeaders : TStringList);
begin
  if (FContentType <> '') then begin
    EncodeSingleHeader(strMimeVersion, RawHeaders, FMimeVersion);
    EncodeContentType(RawHeaders);
    EncodeSingleHeader(strContentDescription, RawHeaders, FContentDescription);
    EncodeSingleHeader(strContentID, RawHeaders, FContentID);
    EncodeContentTransferEncoding(RawHeaders);
    EncodeContentDisposition(RawHeaders);
  end;
end;

{ Encode Mime body from TStream - file name is optional }
procedure TIpMimeEntity.EncodeBodyStream(InStream : TStream; const aFileName : string);
{Begin !!.12}
var
  LargeAttachment : Boolean;
    { Large attachments are handled with memory map streams in order to avoid
      whacko memory issues with TMemoryStream. }
begin
  if (Instream.Size > 0) then begin
    LargeAttachment := (InStream.Size > IpLgAttachSizeBoundry);
    if LargeAttachment then
      ClearBodyLargeAttach(InStream.Size)
    else
    begin
      ClearBody;
      // presize stream for more speed
      FBody.Stream.Size := Trunc(InStream.Size * 1.3695);
    end;
{End !!.12}
    case FContentTransferEncoding of
      em7Bit     : Encode8Bit(InStream);
      em8Bit     : Encode8Bit(InStream);
      emBase64   : EncodeBase64(InStream);
      emBinary   : Encode8Bit(InStream);
      emBinHex   : EncodeBinHex(InStream, aFileName);
      emQuoted   : EncodeQuoted(InStream);
      emUUEncode : EncodeUUEncode(InStream, aFileName);
      emUnknown  : Encode8Bit(InStream);
    end;
  {Begin !!.12}
    FBody.Flush;
    if LargeAttachment then
      { This is a large attachment that was written to a memory map stream.
        Memory map streams are usually created larger than necessary so shrink
        it down to the correct size. }
      TIpMemMapStream(FBody.Stream).Size := TIpMemMapStream(FBody.Stream).DataSize;
  {End !!.12}
  end;
  FOriginalSize := InStream.Size;
  FFileName := ExtractFileName(aFileName);
end;

{ Encode Mime body from TStrings - file name is optional }
procedure TIpMimeEntity.EncodeBodyStrings(InStrings : TStrings; const aFileName : string);
var
  MS : TMemoryStream;
begin
  if (InStrings.Count > 0) then begin
    MS := TMemoryStream.Create;
    try
      InStrings.SaveToStream(MS);
      MS.Position := 0;                                              {!!.03}
      FOriginalSize := MS.Size;
      FFileName := ExtractFileName(aFileName);
      EncodeBodyStream(MS, aFileName);
    finally
      MS.Free;
    end;
  end;
end;

{ Encode Mime body from file }
procedure TIpMimeEntity.EncodeBodyFile(const InFile : string);
var
  FS : TIpMemMapStream;                                                {!!.12}
  i : Integer;
  aExt, aTyp, aSub : string;
  aEnc : TIpMimeEncodingMethod;
begin
  { If content-type, has not been defined for this entity,    }
  { default values for that file extension  will be used.     }
  { These values are defined in the include file, IPDEFCT.INC }
  aTyp := strApplication;
  aSub := strOctetStream;
  aEnc := emBase64;
  aExt := ExtractFileExt(InFile);
  for i := 0 to High(DefExtensions) do
    if (aExt = DefExtensions[i]) then begin
      aTyp := DefContent[i].Typ;
      aSub := DefContent[i].Sub;
      aEnc := DefContent[i].Enc;
      Break;
    end;
  if (FContentType = '') then begin
    FContentType := aTyp;
    FContentSubtype := aSub;
    FContentTransferEncoding := aEnc;
  end;
  if (FContentTransferEncoding = emUnknown) then
    FContentTransferEncoding := aEnc;

  FS := TIpMemMapStream.Create(InFile, True, False);                   {!!.12}
  try
    FS.Open;                                                           {!!.12}
    FOriginalSize := FS.Size;
    FFileName := ExtractFileName(InFile);
    EncodeBodyStream(FS, FFileName);
  finally
    FS.Free;
  end;
end;

{ Decode encoded Mime block body to TStream }
procedure TIpMimeEntity.ExtractBodyStream(OutStream : TStream);
var
  MS : TMemoryStream;
begin
  if (FBody.Size > 0) then begin
   { We want to append the decoded data to the end of OutStream, }
   { so a local memory stream is used since OutStream may be a   }
   { TIpAnsiTextStream, in which case the decoding algorithms    }
   { will overwrite its existing contents.                       }
    MS := TMemoryStream.Create;
    try
      case FContentTransferEncoding of
        em7Bit     : Decode8Bit(MS);
        em8Bit     : Decode8Bit(MS);
        emBase64   : DecodeBase64(MS);
        emBinary   : OutStream.CopyFrom(FBody, FBody.Size);            {!!.14}
        emBinHex   : DecodeBinHex(MS);
        emQuoted   : DecodeQuoted(MS);
        emUUEncode : DecodeUUEncode(MS);
        emUnknown  : Decode8Bit(MS);
      end;
      OutStream.CopyFrom(MS, 0);
    finally
      MS.Free;
    end;
  end;
end;

{ Decode encoded Mime block body to TStrings }
procedure TIpMimeEntity.ExtractBodyStrings(OutStrings : TStrings);
var
  MS : TMemoryStream;
begin
  if (FBody.Size > 0) then begin
    MS := TMemoryStream.Create;
    try
      ExtractBodyStream(MS);
      MS.Position := 0;
      OutStrings.LoadFromStream(MS);
    finally
      MS.Free;
    end;
  end;
end;

{ Decode encoded Mime block body to file }
procedure TIpMimeEntity.ExtractBodyFile(const OutFile : string);
var
  FS : TFileStream;
begin
  if (FBody.Size > 0) then begin
    FS := TFileStreamUTF8.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;

{!!.02}
{ Search all nested levels for specified MIME part }
function TIpMimeEntity.FindNestedMimePart(const aType, aSubType, aContentID : string) : TIpMimeEntity;
var
  i : Integer;
  Blk : TIpMimeEntity;
begin
  Result := nil;
  if (MimeParts.Count > 0) then
    for i := 0 to Pred(MimeParts.Count) do begin
      { ContentID is primary search key }
      if (aContentID <> '') and                                          {!!.12}
         (IsSameString (MimeParts[i].ContentID,                          {!!.12}
                        aContentID, False)) then begin                   {!!.12}
        Result := MimeParts[i];
        Break;
      end else if (IsSameString (MimeParts[i].ContentType,               {!!.12}
                                 aType, False)) and                      {!!.12}
                  (IsSameString (MimeParts[i].ContentSubtype,            {!!.12}
                                 aSubType, False)) then begin            {!!.12}
        Result := MimeParts[i];
        Break;
      end else begin
        Blk := MimeParts[i];
        Result := Blk.FindNestedMimePart(aType, aSubType, aContentID);
        if Assigned(Result) then
          Break;
      end;
    end;
  if Assigned(Result) then
    Result.Body.Position := 0;
end;

{ Create nested Mime block and add to list }
function TIpMimeEntity.NewMimePart : TIpMimeEntity;
begin
  {parent Entity is now multipart}
  FIsMime := True;
  FIsMultipart := True;
  FContentType := strMultipart;
  if (FBoundary = '') then
    FBoundary := GenerateBoundary;

  Result := TIpMimeEntity.Create(Self);
  FMimeParts.Add(Result);
end;

{ Copy Instream to OutStream as is - no decoding }
procedure TIpMimeEntity.Decode8Bit(OutStream : TStream);
var
  FS : TIpAnsiTextStream;
  Abort : Boolean;
begin
  Abort := False;
  FS := TIpAnsiTextStream.Create(OutStream);
  try
    FBody.Position := 0;
    while (FBody.Position < FBody.Size) and not Abort do begin
      FS.WriteLine(FBody.ReadLine);
      DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
    end;
  finally
    FS.Free;
  end;
end;

{ Decode InStream to OutStream - Base64 }
procedure TIpMimeEntity.DecodeBase64(OutStream : TStream);
  { rewritten }                                                      {!!.12}
var
  I : Integer;                                                         {!!.16}
  C : Char;
  InBuf  : array[0..3] of Char;
  OutBuf : array[0..2] of Byte;
  Done  : Boolean;
  Abort : Boolean;
  BufStream : TIpBufferedStream;
begin
  BufStream := (FBody as TIpBufferedStream);
  BufStream.Position := 0;
  Done := False;
  Abort := False;

  while not (Done or Abort) do begin
    { read in the next 4 valid Base64 characters }
    I := 0;
    InBuf := '====';                                                   {!!.15}
    while (I < 4) do begin
      if not BufStream.ReadChar(C) then begin
        Done := True;
        Break;
      end;

      { skip bad characters }
      if (Low(IpD64Table) <= C) and (C <= High(IpD64Table)) then
        if (IpD64Table[C] <> $7F) then begin
          InBuf[I] := C;
          Inc(I);
        end;
    end;

    { Decode 4 characters to 3 bytes }
    I := 0;
    OutBuf[0] := ((IpD64Table[InBuf[0]] shl 2) or (IpD64Table[InBuf[1]] shr 4));
    Inc(I);
    if InBuf[2] <> '=' then begin
      OutBuf[1] := ((IpD64Table[InBuf[1]] shl 4) or (IpD64Table[InBuf[2]] shr 2));
      Inc(I);
      if InBuf[3] <> '=' then begin
        OutBuf[2] := ((IpD64Table[InBuf[2]] shl 6) or IpD64Table[InBuf[3]]);
        Inc(I);
      end else
        Done := True;
    end else
        Done := True;
    OutStream.Write(OutBuf, I);
    DoOnCodingProgress(OutStream.Position, BufStream.FastSize, Abort); {!!.16}
  end;
end;

{ Decode InStream to OutStream - BinHex }
procedure TIpMimeEntity.DecodeBinHex(OutStream : TStream);
var
  InBuf : array[1..4] of Byte;
  OutBuf : array[1..3] of Byte;
  i : Byte;
  btThis, btLast, btNext : Byte;
  ch : AnsiChar;
  // headerlength is encoded as byte, HeaderFileName can only 256 bytes long
  HeaderFileName : Array [0..MaxByte] of Byte;                   {!!.12}{!!.16}
  HeaderLength : byte;                                                  {!!.12}
  CRC : Word;
  DataOffset, DataEnd, HeaderEnd : Longint;
  WS1, WS2 : TMemoryStream;
  Header : BinHexHeader;
  Abort : Boolean;
  BufStream : TIpBufferedStream;

  function NextChar : AnsiChar;
    {- skip past any CRLF's and return the next message stream char }
  var
    c : AnsiChar;
  begin
    c := #0;
    repeat
      BufStream.ReadChar(c);
    until ((c <> #13) and (c <> #10)) or (BufStream.Position = BufStream.Size);
    Result := c;
  end;

  function ValidChar(ch : AnsiChar) : Boolean;
    {- test if ch is a valid BinHex encoded char }
  var
    b : Byte;
  begin
    Result := False;
    b := Ord(ch);
    if (b > 32) and (b < 115) then
      if IpHexBinTable[b] <> $0FF then
        Result := True;
  end;

begin
  Abort := False;
  FBody.Position := 0;
  if Pos('(This file must be converted with BinHex', FBody.ReadLine) = 0 then
    raise EIpBaseException.Create(SBinHexBadFormat);
  if (NextChar <> ':') then
    raise EIpBaseException.Create(SBinHexColonExpected);

  { decode attachment into working stream }
  BufStream := (FBody as TIpBufferedStream);
  WS1 := TMemoryStream.Create;
  try
    i := 0;
    ch := NextChar;
    while (ch <> ':') and (BufStream.Position < BufStream.Size) and not Abort do begin
      if not ValidChar(ch) then
        raise EIpBaseException.Create(SBinHexBadChar);
      Inc(i);
      InBuf[i] := IpHexBinTable[Ord(ch)];
      { decode 4 characters into 3 bytes }
      if (i = 4) then begin
        i := 0;
        { 1st :    upper 6          lower 2 }
        OutBuf[1] := (InBuf[1] shl 2) or ((InBuf[2] shr 4) and $03);
        { 2nd :    upper 4          lower 4 }
        OutBuf[2] := (InBuf[2] shl 4) or ((InBuf[3] shr 2) and $0F);
        { 3rd :    upper 2          lower 6 }
        OutBuf[3] := (InBuf[3] shl 6) or (InBuf[4] and $03F);
        WS1.Write(OutBuf, SizeOf(OutBuf));
      end;
      ch := NextChar;
    end;

    { handle odd characters }
    if (i > 0) then begin
      if (i = 1) then
        raise EIpBaseException.Create(SBinHexOddChar);
      OutBuf[1] := (InBuf[1] shl 2) or ((InBuf[2] shr 4) and $03);
      if (i = 2) then
        WS1.Write(OutBuf, 1)
      else begin
        OutBuf[2] := (InBuf[2] shl 4) or ((InBuf[3] shr 2) and $0F);
        WS1.Write(OutBuf, 2);
      end;
      DoOnCodingProgress(BufStream.Position, BufStream.Size, Abort);
    end;
    if Abort then
      Exit;

    { should be the end of file marker }
    if (ch <> ':') then
      raise EIpBaseException.Create(SBinHexColonExpected);

    { expand RLE sequences }
    WS2 := TMemoryStream.Create;
    try
      WS1.Position := 0;
      btThis := 0;
      while (WS1.Position < WS1.Size) and not Abort do begin
        btLast := btThis;
        WS1.Read(btThis, 1);
        if (btThis <> RLEChar) then
          WS2.Write(btThis, 1)
        else begin
          WS1.Read(btNext, 1);
          if (btNext = 0) then
            WS2.Write(btThis, 1)
          else begin
            btThis := btLast;
            for i := 1 to (btNext - 1) do
              WS2.Write(btThis, 1);
          end;
        end;
        DoOnCodingProgress(WS1.Position, WS1.Size, Abort);
      end;
      if Abort then
        WS2.Free;

      { strip off header }
      FillChar (HeaderFileName, SizeOf (HeaderFileName), $00);           {!!.12}
      FillChar(Header, SizeOf(Header), #0);
      WS2.Position := 0;
      WS2.Read(HeaderLength, SizeOf (Byte));                             {!!.12}
      WS2.Read(HeaderFileName, HeaderLength);                            {!!.12}
      WS2.Read(Header, SizeOf(Header));

      { check header CRC }
      HeaderEnd := WS2.Position;
      WS2.Read(CRC, 2);
      DataOffset := WS2.Position;
      if (CRC <> BinHexCRC(WS2, 0, HeaderEnd)) then
        raise EIpBaseException.Create(SBinHexBadHeaderCRC);
      DataEnd := DataOffset + htonl(Header.DFLong);
      if (DataEnd > WS2.Size) then
        raise EIpBaseException.Create(SBinHexLengthErr);
      if (htonl(Header.RFLong) > 0) then
        raise EIpBaseException.Create(SBinHexResourceForkErr);

      { check data fork CRC - follows data fork }
      WS2.Position := DataEnd;
      WS2.Read(CRC, 2);
      if (CRC <> BinHexCRC(WS2, DataOffset, DataEnd)) then
        raise EIpBaseException.Create(SBinHexBadDataCRC);

      { copy data fork to OutStream }
      WS2.Position := DataOffset;
      OutStream.CopyFrom(WS2, DataEnd - DataOffset);
    finally
      WS2.Free;
    end;
  finally
    WS1.Free;
  end;
end;

{ Decode InStream to OutStream - QuotedPrintable }
procedure TIpMimeEntity.DecodeQuoted(OutStream : TStream);
var
  O, Count, WS : Byte;                                                   {!!.12}
  I : integer;                                                           {!!.12}
  InBuf  : array[0..pred (MaxLine)] of Byte;                             {!!.15}
  OutBuf : array[0..pred (MaxLine)] of Byte;                             {!!.15}
  Decoding : Boolean;
  Keeper : Boolean;
  Abort : Boolean;
  BufStream : TIpBufferedStream;
begin
  Abort := False;
  FBody.Position := 0;
  BufStream := FBody as TIpBufferedStream;
  FillChar(InBuf, SizeOf(InBuf), #0);
  WS := $FF;
  Decoding := True;
  Keeper := False;

  { Skip any CR/LF's to get to the encoded stuff }
  while True do begin
    if not BufStream.ReadChar(Char(InBuf[0])) then
      Exit;
    if ((InBuf[0] <> $0D) and (InBuf[0] <> $0A)) then begin
      Keeper := True;
      Break;
    end;
  end;

  while Decoding and not Abort do begin
    { Initialize }
    if Keeper then begin
      I := 1;
      Keeper := False;
    end else begin
      I := 0;
    end;
    O := 0;

    { Read in one line at a time - skipping over bad characters }
    while True do begin
      if (I > High(InBuf)) then                                        {!!.01}
        raise EIpBaseException.Create(SLineLengthErr);                 {!!.01}
      if not BufStream.ReadChar(Char(InBuf[I])) then
        Break;
      case InBuf[I] of
        $0A : Continue;
        $0D : begin
                Inc(I);
                Break;
              end;
       { Test for potential end of data }
       { '--' is probably the next Mime boundary }
       { $2D : if (I = 1) and (InBuf[0] = $2D) then Exit;}             {!!.03}
      end;
      Inc(I);
    end;

    if I = 0 then Exit;
    Count := I;
    I := 0;

    { Decode data to output stream }
    while I < Count do begin
      case InBuf[I] of
        9       : begin
                    if WS = $FF then
                      WS := O;
                    OutBuf[O] := InBuf[I];
                    Inc(O);
                    Inc(I);
                  end;
        13      : if WS = $FF then begin
                    OutBuf[O] := 13;
                    OutBuf[O+1] := 10;
                    Inc(O, 2);
                    Inc(I);
                  end else begin
                    OutBuf[WS] := 13;
                    OutBuf[WS+1] := 10;
                    O := WS+2;
                    Inc(I);
                  end;
        32      : begin
                    if WS = $FF then
                      WS := O;
                    OutBuf[O] := InBuf[I];
                    Inc(O);
                    Inc(I);
                  end;
        33..60  : begin
                    WS := $FF;
                    OutBuf[O] := InBuf[I];
                    Inc(O);
                    Inc(I);
                  end;
        61      : begin
                    WS := $FF;
                    if I+2 >= Count then Break;
                    case InBuf[I+1] of
                      48 : OutBuf[O] := 0;    {0}
                      49 : OutBuf[O] := 16;   {1}
                      50 : OutBuf[O] := 32;   {2}
                      51 : OutBuf[O] := 48;   {3}
                      52 : OutBuf[O] := 64;   {4}
                      53 : OutBuf[O] := 80;   {5}
                      54 : OutBuf[O] := 96;   {6}
                      55 : OutBuf[O] := 112;  {7}
                      56 : OutBuf[O] := 128;  {8}
                      57 : OutBuf[O] := 144;  {9}
                      65 : OutBuf[O] := 160;  {A}
                      66 : OutBuf[O] := 176;  {B}
                      67 : OutBuf[O] := 192;  {C}
                      68 : OutBuf[O] := 208;  {D}
                      69 : OutBuf[O] := 224;  {E}
                      70 : OutBuf[O] := 240;  {F}
                      97 : OutBuf[O] := 160;  {a}
                      98 : OutBuf[O] := 176;  {b}
                      99 : OutBuf[O] := 192;  {c}
                     100 : OutBuf[O] := 208;  {d}
                     101 : OutBuf[O] := 224;  {e}
                     102 : OutBuf[O] := 240;  {f}
                    end;
                    case InBuf[I+2] of
                      48 : ;                             {0}
                      49 : OutBuf[O] := OutBuf[O] + 1;   {1}
                      50 : OutBuf[O] := OutBuf[O] + 2;   {2}
                      51 : OutBuf[O] := OutBuf[O] + 3;   {3}
                      52 : OutBuf[O] := OutBuf[O] + 4;   {4}
                      53 : OutBuf[O] := OutBuf[O] + 5;   {5}
                      54 : OutBuf[O] := OutBuf[O] + 6;   {6}
                      55 : OutBuf[O] := OutBuf[O] + 7;   {7}
                      56 : OutBuf[O] := OutBuf[O] + 8;   {8}
                      57 : OutBuf[O] := OutBuf[O] + 9;   {9}
                      65 : OutBuf[O] := OutBuf[O] + 10;  {A}
                      66 : OutBuf[O] := OutBuf[O] + 11;  {B}
                      67 : OutBuf[O] := OutBuf[O] + 12;  {C}
                      68 : OutBuf[O] := OutBuf[O] + 13;  {D}
                      69 : OutBuf[O] := OutBuf[O] + 14;  {E}
                      70 : OutBuf[O] := OutBuf[O] + 15;  {F}
                      97 : OutBuf[O] := OutBuf[O] + 10;  {a}
                      98 : OutBuf[O] := OutBuf[O] + 11;  {b}
                      99 : OutBuf[O] := OutBuf[O] + 12;  {c}
                     100 : OutBuf[O] := OutBuf[O] + 13;  {d}
                     101 : OutBuf[O] := OutBuf[O] + 14;  {e}
                     102 : OutBuf[O] := OutBuf[O] + 15;  {f}
                    end;
                    Inc(I, 3);
                    Inc(O);
                  end;
        62..126 : begin
                    WS := $FF;
                    OutBuf[O] := InBuf[I];
                    Inc(O);
                    Inc(I);
                  end;
        else
          Inc(I);
      end;
    end;

    if O>0 then
      OutStream.Write(OutBuf, O)
    else
      Break;   { OutBuf is empty }
    DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
  end;
end;

{ Decode InStream to OutStream - UUEncode }
procedure TIpMimeEntity.DecodeUUEncode(OutStream : TStream);
var
  I, O, Len, Count : Byte;
  InBuf  : array[0..85] of Byte;
  OutBuf : array[0..65] of Byte;
  FirstLine : Boolean;
  Abort : Boolean;
  BufStream : TIpBufferedStream;
begin
  Abort := False;
  FBody.Position := 0;
  BufStream := FBody as TIpBufferedStream;
  FirstLine := True;
  while True and not Abort do begin
    { Initialize }
    I := 0;
    O := 0;

    { Skip any CR/LF's to get to the encoded stuff }
    while True do begin
      if not BufStream.ReadChar(Char(InBuf[0])) then
        Exit;
      if FirstLine then begin
        if ((InBuf[0] <> $0D) and (InBuf[0] <> $0A)) then begin
          FirstLine := False;
          Break;
        end;
     end else begin
        if ((InBuf[0] = $0D) or (InBuf[0] = $0A)) then FirstLine := True;
      end;
    end;

    { We're done }
    if AnsiChar(InBuf[0]) = '`' then Exit;

    { Get count for this line }
    Len := (((InBuf[0] - $20) and $3F) * 4) div 3;
    if (((InBuf[0] - $20) and $3F) * 4) mod 3 <> 0 then
      Inc(Len);

    Count := FBody.Read(InBuf, Len);

    { Unexpected situation }
    if (Count <> Len) or (Count > 63) then
      raise EIpBaseException.Create(SUUEncodeCountErr);

    { Decode buffer }
    while (I < Count) do begin
      if ((Count - I) >= 4) then begin
        OutBuf[O] := (((InBuf[I] - $20) and $3F) shl 2) or
          (((InBuf[I+1] - $20) and $3F) shr 4);
        OutBuf[O+1] := (((InBuf[I+1] - $20) and $3F) shl 4) or
          (((InBuf[I+2] - $20) and $3F) shr 2);
        OutBuf[O+2] := (((InBuf[I+2] - $20) and $3F) shl 6) or
          (((InBuf[I+3] - $20) and $3F));
        Inc(O, 3);
      end else begin
        if (Count >= 2) then begin
          OutBuf[O] := (((InBuf[I] - $20) and $3F) shl 2) or
            (((InBuf[I+1] - $20) and $3F) shr 4);
          Inc(O);
        end;
        if (Count >= 3) then begin
          OutBuf[O+1] := (((InBuf[I+1] - $20) and $3F) shl 4) or
            (((InBuf[I+2] - $20) and $3F) shr 2);
          Inc(O);
        end;
      end;
      Inc(I, 4);
    end;
    OutStream.Write(OutBuf, O);
    DoOnCodingProgress(OutStream.Position, FBody.Size, Abort);
  end;
end;

{ Encode InStream to OutStream - as is, no encoding }
procedure TIpMimeEntity.Encode8Bit(InStream : TStream);
var
  FS : TIpAnsiTextStream;
  Abort : Boolean;
begin
  Abort := False;
  FS := TIpAnsiTextStream.Create(InStream);
  try
    while not (FS.AtEndOfStream or Abort) do begin
      FBody.WriteLine(FS.ReadLine);
      DoOnCodingProgress(FS.Position, FS.Size, Abort);
    end;
  finally
    FS.Free;
  end;
end;

{ Encode InStream to OutStream - Base64 }
procedure TIpMimeEntity.EncodeBase64(InStream : TStream);
begin
  OctetStreamToHextetStream(InStream, FBody, Ip64Table, '=', #0);
end;

{ Encode InStream to OutStream - BinHex }
procedure TIpMimeEntity.EncodeBinHex(InStream : TStream;
                                     const aFileName : string);
var
  HeaderFileName : string;                                              {!!.12}
  CRC : Word;
  DataOffset : DWord;
  PrevByte, CurrByte, i : Byte;
  Header : BinHexHeader;
  WS1, WS2 : TMemoryStream;
  Abort : Boolean;

begin
  Abort := False;
  WS1 := TMemoryStream.Create;
  try
    { start with file name }
    if (Length(aFileName) < MaxLine) then
      HeaderFileName := UpperCase(ExtractFileName(aFileName))
    else
      HeaderFileName := Copy(UpperCase(ExtractFileName(aFileName)), 1, MaxLine);
    WS1.Write(HeaderFileName, Length(HeaderFileName) + 1);

    { build rest of file header and header CRC and add to working stream }
    FillChar(Header, SizeOf(Header), #0);
    Move(BinHexFileType, Header.FileType, SizeOf(Header.FileType));
    Move(BinHexFileType, Header.Creator, SizeOf(Header.Creator));
    Header.DFLong := htonl(InStream.Size);
    Header.RFLong := 0;
    WS1.Write(Header, SizeOf(Header));
    CRC := BinHexCRC(WS1, 0, WS1.Size);
    WS1.Write(CRC, 2);

    { append data fork and data CRC to working stream }
    DataOffset := WS1.Position;
    InStream.Position := 0;
    WS1.CopyFrom(InStream, InStream.Size);
    CRC := BinHexCRC(WS1, DataOffset, WS1.Size);
    WS1.Write(CRC, 2);

    { tack on resource fork CRC - not used but still required }
    CRC := 0;
    WS1.Write(CRC, 2);

    { go back and compress RLE sequences }
    WS2 := TMemoryStream.Create;
    try
      WS1.Position := 0;
      CurrByte := 0;
      while (WS1.Position < WS1.Size) and not Abort do begin
        PrevByte := CurrByte;
        WS1.Read(CurrByte, 1);
        if (CurrByte <> PrevByte) then
          WS2.Write(CurrByte, 1)
        else begin
          i := 1;
          repeat
            i := i + WS1.Read(CurrByte, 1);
          until (CurrByte <> PrevByte) or (i = 255) or
                (WS1.Position = WS1.Size);
          if (i > 2) then begin
            WS2.Write(RLEChar, 1);
            WS2.Write(i, 1);
            WS2.Write(CurrByte, 1);
          end else begin
            WS2.Write(PrevByte, 1);
            WS2.Write(CurrByte, 1);
          end;
        end;
        DoOnCodingProgress(WS1.Position, WS1.Size, Abort);
      end;
      if Abort then
        Exit;

      { write out preamble }
      FBody.WriteLine('(This file must be converted with BinHex 4.0)');

      { Encode compressed stream and stream it out }
      WS2.Position := 0;
      OctetStreamToHextetStream(WS2, FBody, IpBinHexTable, #0, ':');
    finally
      WS2.Free;
    end;
  finally
    WS1.Free;
  end;
end;

{ Encode InStream to OutStream - QuotedPrintable }
procedure TIpMimeEntity.EncodeQuoted(InStream : TStream);
var
  O, W : Integer;
  WordBuf, OutBuf : array[0..80] of AnsiChar;
  CurChar : AnsiChar;
  Abort : Boolean;
  ByteStream : TIpByteStream;

  procedure SendLine;
  begin
    if (OutBuf[O-1] = #9) or (OutBuf[O-1] = #32) then begin
      OutBuf[O] := '=';
      Inc(O);
    end;
    FBody.WriteLineZ(OutBuf);
    FillChar(OutBuf, SizeOf(OutBuf), #0);
    O := 0;
  end;

  procedure AddWordToOutBuf;
  var
    J : Integer;
  begin
    if (O + W) > 74 then SendLine;
    for J := 0 to (W - 1) do begin
      OutBuf[O] := WordBuf[J];
      Inc(O);
    end;
    W := 0;
  end;

  procedure AddHexToWord(B : Byte);
  begin
    if W > 73 then AddWordToOutBuf;
    WordBuf[W] := '=';
    WordBuf[W+1] := HexDigits[B shr 4];
    WordBuf[W+2] := HexDigits[B and $F];
    Inc(W, 3)
  end;

begin
  Abort := False;
  O := 0;
  W := 0;
  FillChar(OutBuf, SizeOf(OutBuf), #0);
  ByteStream := TIpByteStream.Create(InStream);
  try
    while ByteStream.Read(Byte(CurChar)) and not Abort do begin
      if (Ord(CurChar) in [33..60, 62..126]) then begin
        WordBuf[W] := CurChar;
        Inc(W);
        if W > 74 then AddWordToOutBuf;
      end else if (CurChar = ' ') or (CurChar = #9) then begin
        WordBuf[W] := CurChar;
        Inc(W);
        AddWordToOutBuf;
      end else if (CurChar = #13) then begin
        AddWordToOutBuf;
        SendLine;
      end else if (CurChar = #10) then begin
        { Do nothing }
      end else begin
        AddHexToWord(Byte(CurChar));
      end;
      DoOnCodingProgress(ByteStream.Position, ByteStream.Size, Abort);
    end;
  finally
    ByteStream.Free;
  end;
end;

{ Encode InStream to OutStream - UUEncode }
procedure TIpMimeEntity.EncodeUUEncode(InStream : TStream;
                                       const aFileName : string);
var
  I, O, Count, Temp : Byte;
  InBuf  : array[1..45] of Byte;
  OutBuf : array[0..63] of AnsiChar;
  Abort : Boolean;
begin
  Abort := False;
  FBody.WriteLine('begin 600 ' + aFileName);

  { Encode and stream the attachment }
  repeat
    Count := InStream.Read(InBuf, SizeOf(InBuf));
    if Count <= 0 then Break;
    I := 1;
    O := 0;
    OutBuf[O] := AnsiChar(IpUUTable[Count and $3F]);
    Inc(O);
    while I+2 <= Count do begin
      { Encode 1st byte }
      Temp := (InBuf[I] shr 2);
      OutBuf[O] := AnsiChar(IpUUTable[Temp and $3F]);

      { Encode 1st/2nd byte }
      Temp := (InBuf[I] shl 4) or (InBuf[I+1] shr 4);
      OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);

      { Encode 2nd/3rd byte }
      Temp := (InBuf[I+1] shl 2) or (InBuf[I+2] shr 6);
      OutBuf[O+2] := AnsiChar(IpUUTable[Temp and $3F]);

      { Encode 3rd byte }
      Temp := (InBuf[I+2] and $3F);
      OutBuf[O+3] := AnsiChar(IpUUTable[Temp]);

      Inc(I, 3);
      Inc(O, 4);
    end;

    { Are there odd bytes to add? }
    if (I <= Count) then begin
      Temp := (InBuf[I] shr 2);
      OutBuf[O] := AnsiChar(IpUUTable[Temp and $3F]);

      { One odd byte }
      if (I = Count) then begin
        Temp := (InBuf[I] shl 4) and $30;
        OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);
        Inc(O, 2);
      { Two odd bytes }
      end else begin
        Temp := ((InBuf[I] shl 4) and $30) or ((InBuf[I+1] shr 4) and $0F);
        OutBuf[O+1] := AnsiChar(IpUUTable[Temp and $3F]);
        Temp := (InBuf[I+1] shl 2) and $3C;
        OutBuf[O+2] := AnsiChar(IpUUTable[Temp and $3F]);
        Inc(O, 3);
      end;
    end;

    { Add CR/LF }
    OutBuf[O] := #13;
    OutBuf[O+1] := #10;

    { Write line to stream }
    FBody.Write(OutBuf, (O + 2));
    DoOnCodingProgress(InStream.Position, InStream.Size, Abort);
  until (Count < SizeOf(InBuf)) or Abort;

  { Add terminating end }
  FBody.WriteLine('`');
  FBody.WriteLine('end');
end;

{ Translate each 3 bytes into 4 hextets and encode according to table }
procedure TIpMimeEntity.OctetStreamToHextetStream(InStream : TStream;
                                                  OutStream : TIpAnsiTextStream;
                                                  const Table;
                                                  PadChar, Delim : AnsiChar);
var
  OutBuf: array[0..MaxLineEncode-1] of Char;                           {!!.12}{!!.13}
  OutBufLen: Integer;                                                  {!!.12}
  Abort : Boolean;

  procedure FlushOutBuf;
    {- write out encoded buffer to message stream }
  begin
    if OutBufLen > 0 then begin                                        {!!.12}
      OutStream.WriteLineArray(OutBuf, OutBufLen);
      OutBufLen := 0;                                                  {!!.12}
    end;
  end;

  procedure OutChar(ch : AnsiChar);
    {- buffer the character to go out }
  begin
    if OutBufLen >= MaxLineEncode - 1 then                             {!!.12}{!!.13}
      FlushOutBuf;
    OutBuf[OutBufLen] := Ch;                                           {!!.12}
    inc(OutBufLen);                                                    {!!.12}
  end;

type
  TBuffer = array[0..MaxInt-1] of Byte;
var
  Buffer: ^TBuffer;
  I, Count: Cardinal;
begin
  if InStream is TMemoryStream then
    Buffer := (InStream as TMemoryStream).Memory
  else
    if InStream is TIpMemMapStream then
      Buffer := (InStream as TIpMemMapStream).Memory
    else
      raise EIpBaseException.Create(SNoMemoryStreamErr);

  Abort := False;
  OutBufLen := 0;                                                      {!!.12}
  if (Delim <> #0) then
    OutChar(Delim);

  { Encode and stream the attachment }
  I := 0;
  Count := InStream.Size div 3 * 3;
  while I < Count do
  begin
    { Encode 1st byte }
    OutBuf[OutBufLen] := Char(TIp6BitTable(Table)[Buffer[I] shr 2]);

    { Encode 1st/2nd byte }
    OutBuf[OutBufLen+1] := Char(TIp6BitTable(Table)[((Buffer[I] shl 4) or (Buffer[I+1] shr 4)) and $3F]);

    { Encode 2nd/3rd byte }
    OutBuf[OutBufLen+2] := Char(TIp6BitTable(Table)[((Buffer[I+1] shl 2) or (Buffer[I+2] shr 6)) and $3F]);

    { Encode 3rd byte }
    OutBuf[OutBufLen+3] := Char(TIp6BitTable(Table)[Buffer[I+2] and $3F]);

    Inc(OutBufLen, 4);
    if OutBufLen >= MaxLineEncode - 1 then                             {!!.12}{!!.13}
    begin
      FlushOutBuf;
      if i mod 100 = 0 then
        DoOnCodingProgress(I, Count, Abort);
      if Abort then
        break;
    end;
    Inc(I, 3);
  end;

  Count := InStream.Size;
  { Are there odd bytes to add? }
  if (I < Count) then begin
    OutChar(TIp6BitTable(Table)[Buffer[I] shr 2]);

    { One odd byte }
    if I = Count-1 then begin
      OutChar(TIp6BitTable(Table)[(Buffer[I] shl 4) and $30]);

      if (PadChar <> #0) then
        OutChar(PadChar);
    { Two odd bytes }
    end else begin
      OutChar(TIp6BitTable(Table)[((Buffer[I] shl 4) and $30) or (((Buffer[I+1] shr 4) and $0F)) and $3F]);
      OutChar(TIp6BitTable(Table)[(Buffer[I+1] shl 2) and $3C]);
    end;
    { Add padding }
      if (PadChar <> #0) then
        OutChar(PadChar);
  end;

  if (Delim <> #0) then
    OutChar(Delim);
  FlushOutBuf;
end;

{Begin !!.12}
procedure TIpMIMEEntity.ReadBody(InStream : TIpAnsiTextStream; const StartLine : string);
var
  S : string;
begin
  S := StartLine;
  { read in message body up to message terminator '.' }
  {while not ((S = '.') or AtEndOfStream) do begin}
  while not InStream.AtEndOfStream do begin
    Body.WriteLine(S);
    S := InStream.ReadLine;
  end;
  { write final line }
  Body.WriteLine(S);
end;
{End !!.12}


{ TIpMessage }
constructor TIpMessage.CreateMessage;
begin
  inherited Create(nil);
  FBCC        := TStringList.Create;
  FCC         := TStringList.Create;
  FNewsgroups := TStringList.Create;
  FPath       := TStringList.Create;
  FReceived   := TStringList.Create;
  FRecipients := TStringList.Create;
  FReferences := TStringList.Create;
  FUserFields := TStringList.Create;
  FHeaders    := TIpHeaderCollection.Create (Self);                    {!!.12}
  MsgStream := TIpAnsiTextStream.CreateEmpty;
  NewMessageStream;
end;

destructor TIpMessage.Destroy;
begin
  Clear;
  FBCC.Free;
  FCC.Free;
  FNewsgroups.Free;
  FPath.Free;
  FReceived.Free;
  FRecipients.Free;
  FReferences.Free;
  FUserFields.Free;
  FHeaders.Free;                                                         {!!.12}
  MsgStream.FreeStream;
  MsgStream.Free;
  inherited Destroy;
end;

{Begin !!.13}
procedure TIpMessage.CheckAllHeaders;
var
  i         : Integer;
  j         : Integer;
  HeaderNum : Integer;
begin
  FAttachmentCount := 0;

  { Roll through the list of headers specifically handled by iPRO.
    When one is found, move it into the data structure specific to that
    header field. }
  for i := 0 to IpMaxHeaders - 1 do begin
    if (IpHeaderXRef[i].FieldType = htUserFields) or
       (IpHeaderXRef[i].FieldType = htReceived) then begin
      for j := 0 to Headers.Count - 1 do begin
        if StrLIComp (PChar (IpHeaderXRef[i].FieldString),
                      PChar (Headers.Items[j].Name),
                      Length (IpHeaderXRef[i].FieldString)) = 0 then
          CheckHeaderType (Headers.Items[j],
                           IpHeaderXRef[i].FieldType);
      end;
      
    end else begin
      HeaderNum := Headers.HasHeader (IpHeaderXRef[i].FieldString);
      if HeaderNum >= 0 then
        CheckHeaderType (Headers.Items[HeaderNum],
                         IpHeaderXRef[i].FieldType);
    end;
  end;
end;

procedure TIpMessage.CheckHeaderType (HeaderInfo : TIpHeaderItem;
                                      HeaderType : TIpHeaderTypes);

  function ExtractSingleHeader(HeaderInfo : TIpHeaderItem) : string;
  begin
    Result := Trim(HeaderInfo.Value.Text);
    HeaderInfo.IsProperty := True;                                     {!!.13}
  end;

  procedure ExtractCSVHeader(HeaderInfo : TIpHeaderItem;
                         var AList      : TStringList);
  var
    WorkString : string;
  begin
    WorkString := ExtractSingleHeader(HeaderInfo);
    Parse (WorkString, ',', AList);
    HeaderInfo.IsProperty := True;                                     {!!.13}
  end;

  procedure ExtractListHeader(HeaderInfo : TIpHeaderItem;
                           var AList      : TStringList);
  begin
    AList.Assign (HeaderInfo.Value);
    HeaderInfo.IsProperty := True;                                     {!!.13}
  end;

  procedure ExtractAppendListHeader(HeaderInfo : TIpHeaderItem;
                              const IncludeName : Boolean;             {!!.13}
                                var AList      : TStringList);
  var
    i : Integer;
  begin
    for i := 0 to HeaderInfo.Value.Count - 1 do
{Begin !!.13}
      if IncludeName then
        AList.Add (HeaderInfo.Name + ': ' + HeaderInfo.Value[i])
      else
        AList.Add (HeaderInfo.Value[i]);
    HeaderInfo.IsProperty := True;
{End !!.13}
  end;

begin
  case HeaderType of
    htBCC             :
      ExtractCSVHeader(HeaderInfo, FBCC);
    htCC              :
      ExtractCSVHeader(HeaderInfo, FCC);
    htControl         :
      FControl := ExtractSingleHeader(HeaderInfo);
    htDate            :
      FDate := ExtractSingleHeader(HeaderInfo);
    htDispositionNotify :
      FDispositionNotify := ExtractSingleHeader(HeaderInfo);
    htFrom            :
      FFrom := ExtractSingleHeader(HeaderInfo);
    htFollowUp        :
      FFollowUpTo := ExtractSingleHeader(HeaderInfo);
    htInReplyTo       :
      FInReplyTo := ExtractSingleHeader(HeaderInfo);
    htKeywords        :
      FKeywords := ExtractSingleHeader(HeaderInfo);
    htMessageID       :
      FMessageID := ExtractSingleHeader(HeaderInfo);
    htNewsgroups      :
      ExtractCSVHeader(HeaderInfo, FNewsgroups);
    htNNTPPostingHost :
      FNNTPPostingHost := ExtractSingleHeader(HeaderInfo);
    htOrganization    :
      FOrganization := ExtractSingleHeader(HeaderInfo);
    htPath            :
      ExtractListHeader(HeaderInfo, FPath);
    htPostingHost     :
      FPostingHost := ExtractSingleHeader(HeaderInfo);
    htReceived        :
      ExtractAppendListHeader(HeaderInfo, False, FReceived);           {!!.13}
    htReferences      :
      ExtractListHeader(HeaderInfo, FReferences);
    htReplyTo         :
      FReplyTo := ExtractSingleHeader(HeaderInfo);
    htReturnPath      :
      FReturnPath := ExtractSingleHeader(HeaderInfo);
    htSender          :
      FSender := ExtractSingleHeader(HeaderInfo);
    htSubject         :
      FSubject := ExtractSingleHeader(HeaderInfo);
    htTo              :
      ExtractCSVHeader(HeaderInfo, FRecipients);
    htUserFields      :
      ExtractAppendListHeader(HeaderInfo, True, FUserFields);          {!!.13}
    htXIpro           : begin
    end;
  end;
end;
{End !!.12}

{ Clear properties and free message stream }
procedure TIpMessage.Clear;
begin
  inherited Clear;

  FAttachmentCount := 0;                                               {!!.12}
  FMessageTag := 0;                                                    {!!.15}

  FBCC.Clear;
  FCC.Clear;
  FDate := '';
  FDispositionNotify := '';                                            {!!.12}
  FFrom := '';
  FInReplyTo := '';
  FKeywords := '';
  FFollowupTo := '';                                                   {!!.15}
  FControl := '';                                                      {!!.15}
  FMessageID := '';
  FNewsgroups.Clear;
  FNNTPPostingHost := '';
  FOrganization := '';
  FPath.Clear;
  FPostingHost := '';
  FReceived.Clear;
  FRecipients.Clear;
  FReferences.Clear;
  FReplyTo := '';
  FReturnPath := '';
  FSender := '';
  FSubject := '';
  FUserFields.Clear;
  FHeaders.Clear;                                                      {!!.15}
  MsgStream.FreeStream;
end;

{Begin !!.12}
{ Get headers, body, and MIME parts (if any) }
procedure TIpMessage.DecodeMessage;

var
  AttDepth     : Integer;

  function IsAttachmentStart (const s : string) : Boolean;
  type
    TAttState = (asBegin, asHaveBegin,
                 asNumber1, asNumberSp,
                 asOpenCurly, asNumber2, asNumber2Sp, asCloseCurly,
                 asQuote1, asDblQuote1, AsAlnum1);

  var
    State : TAttState;
    i     : Integer;
    SLen  : Integer;

  begin
    Result := False;
    State  := asBegin;
    i      := 1;
    SLen   := Length (s);

    while i < SLen do begin
      case State of
        asBegin     : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if LowerCase (Copy (s, i, 5)) = 'begin' then begin
            State := asHaveBegin;
            Inc (i, 5);
          end else
            Break;
        end;

        asHaveBegin : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if s[i] = '{' then begin
            Inc (i);
            State := asNumber2;
          end else if s[i] in ['0'..'9'] then begin
            Inc (i);
            State := asNumber1;
          end else
            Break;
        end;

        asNumber1 : begin
          if s[i] in ['0'..'9'] then
            Inc (i)
          else if s[i] in [' ', #09] then begin
            Inc (i);
            State := asNumberSp;
          end else
            Break;
        end;

        asNumberSp : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if s[i] = '"' then begin
            Inc (i);
            State := asDblQuote1;
          end else if s[i] = '''' then begin
            Inc (i);
            State := asQuote1;
          end else if s[i] in ['!'..'~'] then begin
            Inc (i);
            State := asAlNum1;
          end else
            Break;
        end;

        asOpenCurly : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if s[i] in ['0'..'9'] then begin
            Inc (i);
            State := asNumber2;
          end else
            Break;
        end;

        asNumber2 : begin
          if s[i] in ['0'..'9'] then
            Inc (i)
          else if s[i] in [' ', #09] then begin
            Inc (i);
            State := asNumber2Sp;
          end else if s[i] = '}' then begin
            State := asCloseCurly;
            Inc (i);
          end else
            Break;
        end;

        asNumber2Sp : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if s[i] = '}' then begin
            Inc (i);
            State := asCloseCurly;
          end else
            Break;
        end;

        asCloseCurly : begin
          if s[i] in [' ', #09] then
            Inc (i)
          else if s[i] = '"' then begin
            Inc (i);
            State := asDblQuote1;
          end else if s[i] = '''' then begin
            Inc (i);
            State := asQuote1;
          end else
            Break;
        end;

        asQuote1 : begin
          if s[i] in [' '..'&', '('..'~'] then
            Inc (i)
          else if s[i] = '''' then begin
            Result := True;
            Break;
          end else
            Break;
        end;

        asDblQuote1 : begin
          if s[i] in [' '..'!', '#'..'~'] then
            Inc (i)
          else if s[i] = '"' then begin
            Result := True;
            Break;
          end else
            Break;
        end;

        AsAlnum1 : begin
          if s[i] in ['!'..'~'] then begin
            Result := True;
            Break;
          end else
            Break;
        end;

      end;
    end;
  end;

  function IsAttachmentEnd (const s : string) : Boolean;
  begin
    if LowerCase (Copy (s, 1, 3)) = 'end' then
      Result := True
    else
      Result := False;
  end;

  procedure CheckForAttachment (const s : string);
  begin
    if IsAttachmentStart (s) then begin
      if AttDepth = 0 then
        Inc (FAttachmentCount);
      Inc (AttDepth);
    end else if (IsAttachmentEnd (s)) and
                (FAttachmentCount > 0) then
      Dec (AttDepth);
  end;
{End !!.12}
var
  RawHeaders : TStringList;
  S : string;
  i, j : Integer;                                                      {!!.13}
begin
  { get message headers}
  Position := 0;
  RawHeaders := TStringList.Create;
  try
    S := ReadLine;
    repeat
      if S <> '' then                                                  {!!.15}
        RawHeaders.Add(S);
      S := ReadLine;
    until (S = '');

    FHeaders.Clear;                                                    {!!.12}
    FHeaders.LoadHeaders (RawHeaders, False);                          {!!.12}
    CheckAllHeaders;                                                   {!!.12}

    { decode MIME headers }
    DecodeMimeHeaders(RawHeaders);

{Begin !!.13}
    { If this is a MIME message, mark the MIME headers as being exposed via an
      iPRO property. }
    if FIsMime then
      for i := Low(IpMimeHeaders) to High(IpMimeHeaders) do begin
        j := FHeaders.HasHeader(IpMimeHeaders[i]);
        if j > -1 then
          FHeaders.Items[j].IsProperty := True;
      end;
{End !!.13}
  finally
    RawHeaders.Free;
  end;

  { if message is mime, then decode mime parts }
  if IsMime then begin                                                 {!!.01}
    if (FContentDispositionType = strAttachment) then begin            {!!.12}
      Inc (FParent.FAttachmentCount);                                  {!!.12}{!!.15}
      DecodeEntityAsAttachment(MsgStream)                              {!!.01}
    end else                                                           {!!.12}
      DecodeEntity(MsgStream);
  end else begin
    { otherwise, just read in the message body. }
    repeat  { skip over blank lines between headers and body }
      S := ReadLine;
    until (S <> '') or AtEndOfStream;

    { read in message body up to message terminator '.' }
    {while not ((S = '.') or AtEndOfStream) do begin}                  {!!.10}
    while not AtEndOfStream do begin                                   {!!.10}
      Body.WriteLine(S);
      AttDepth := 0;                                                   {!!.12}
      CheckForAttachment (S);                                          {!!.12}
      S := ReadLine;
    end;
    { write final line }                                               {!!.10}
    if S <> '' then                                                    {!!.13}
      Body.WriteLine(S);                                               {!!.10}

{Begin !!.12}
    { Read the message body. }
    {ReadBody(MsgStream, S); }
{End !!.12}
  end;
  Body.Position := 0;
end;

{ Build message stream with headers, body, and MIME parts (if any) }
procedure TIpMessage.EncodeMessage;
var
  i : Integer;
  Size : Longint;                                                      {!!.12}
  FileName : string;                                                   {!!.12}
  Strm : TIpMemMapStream;                                              {!!.12}
  RawHeaders : TStringList;
begin
  NewMessageStream;
{Begin !!.12}
  { If we have some very large attachments then we need to use a memory mapped
    file stream instead of TMemory, in order to improve performance. }
  Size := 0;
  for i := 0 to Pred(FMimeParts.Count) do
    inc(Size, FMimeParts[i].FOriginalSize);
  if Size > IpLgAttachSizeBoundry then begin
    MsgStream.FreeStream;
    FileName := GetTemporaryFile(GetTemporaryPath);
    if FileExistsUTF8(FileName) then
      DeleteFileUTF8(FileName);
    Strm := TIpMemMapStream.Create(FileName, False, True);
    Strm.Size := Trunc(Size * 1.5);
    Strm.Open;
    MsgStream.Stream := Strm;
  end;
{End !!.12}
  if (FContentType <> '') then begin
    FIsMime := True;
    FMimeVersion := '1.0';
  end;
  RawHeaders := TStringList.Create;
  try
    EncodeSingleHeader(strReturnPath, RawHeaders, FReturnPath);
    EncodeMultiHeader(strReceived, RawHeaders, FReceived, #09, True);
    EncodeListHeader(strPath, RawHeaders, FPath, ',', True);
    EncodeListHeader(strNewsgroups, RawHeaders, FNewsgroups, ',', False); {!!.14}
    EncodeSingleHeader(strMessageID, RawHeaders, FMessageID);
    EncodeSingleHeader (strDispositionNotify, RawHeaders,                {!!.12}
                        FDispositionNotify);                             {!!.12}
    EncodeSingleHeader(strReplyTo, RawHeaders, FReplyTo);
    EncodeSingleHeader(strFrom, RawHeaders, FFrom);
    EncodeListHeader(strTo, RawHeaders, FRecipients, ',', True);
    EncodeSingleHeader(strSubject, RawHeaders, FSubject);
    EncodeSingleHeader(strDate, RawHeaders, FDate);
    EncodeSingleHeader(strOrganization, RawHeaders, FOrganization);
    EncodeListHeader(strCC, RawHeaders, FCC, ',', False);
    EncodeListHeader(strBCC, RawHeaders, FBCC, ',', False);
    EncodeSingleHeader(strInReplyTo, RawHeaders, FInReplyTo);
    EncodeListHeader(strReferences, RawHeaders, FReferences, '', False);
    EncodeSingleHeader(strSender, RawHeaders, FSender);
    EncodeSingleHeader(strKeywords, RawHeaders, FKeywords);
    EncodeMultiHeader('', RawHeaders, FUserFields, Char(0), False);
    EncodeSingleHeader(strControl, RawHeaders, FControl);               {!!.12}
    EncodeSingleHeader(strFollowUp, RawHeaders, FFollowupTo);           {!!.12}
{Begin !!.13}
    for i := 0 to Pred(Headers.Count) do
      { Write the header out only if it is not a header exposed via an iPRO
        property. }
      if (not Headers.Items[i].IsProperty) then begin
        if Headers.Items[i].Value.Count = 1 then
          EncodeSingleHeader(Headers.Items[i].Name + ': ', RawHeaders,
                             Headers.Items[i].Value[0])
        else
          EncodeMultiheader(Headers.Items[i].Name + ': ', RawHeaders,
                            Headers.Items[i].Value, #09, True);
      end;
{End !!.13}
    if IsMime then
      EncodeMimeHeaders(RawHeaders);
    if (RawHeaders.Count = 0) then
      Exit;
    for i := 0 to Pred(RawHeaders.Count) do
      WriteLine(RawHeaders[i]);
  finally
    RawHeaders.Free;
  end;

{Begin !!.13}
  WriteLine('');
  if IsMime then
    EncodeEntity(MsgStream)
  else if (FBody.Size > 0) then begin
    FBody.Position := 0;
    repeat
      WriteLine(Body.ReadLine);
    until FBody.AtEndOfStream;
  end;  { if }
{End !!.13}
end;

{ Load message from file stream and decode }
procedure TIpMessage.LoadFromFile(const aFileName : string);
{Begin !!.12}
var
  SourceStream : TIpMemMapStream;
{End !!.12}
begin
  Clear;
  NewMessageStream;                                                    {!!.03}
{Begin !!.12}
  SourceStream := TIpMemMapStream.Create(aFileName, True, False);
  try
    SourceStream.Open;
{Begin !!.15}
    if SourceStream.Size > IpLgAttachSizeBoundry then begin
      MsgStream.FreeStream;
      MsgStream.Stream := SourceStream;
    end
    else
      MsgStream.CopyFrom(SourceStream, 0);
  finally
    if MsgStream.Stream <> SourceStream then
      SourceStream.Free;
{End !!.15}
  end;
{End !!.12}

  try                                                                  {!!.03}
    DecodeMessage;
  except                                                               {!!.03}
    { just eat the exception, the messge might be corrupt, but the }
    { raw text (MessageStream property) will still be available    }
  end;                                                                 {!!.03}
end;

{Begin !!.12}
procedure TIpMessage.LoadFromStream(aStream : TStream);
var
  FileName : string;
  Strm : TIpMemMapStream;
begin
  Clear;
  NewMessageStream;
  if aStream.Size > IpLgAttachSizeBoundry then begin
    MsgStream.FreeStream;
    FileName := GetTemporaryFile(GetTemporaryPath);
    if FileExistsUTF8(FileName) then
      DeleteFileUTF8(FileName);
    Strm := TIpMemMapStream.Create(FileName, False, True);
    Strm.Size := aStream.Size;
    Strm.Open;
    MsgStream.Stream := Strm;
  end;
  MsgStream.CopyFrom(aStream, 0);

  try
    DecodeMessage;
  except
    { just eat the exception, the messge might be corrupt, but the }
    { raw text (MessageStream property) will still be available    }
  end;                                                               
end;


{ Create new message stream but retain existing decoded message }
procedure TIpMessage.NewMessageStream;
begin
  MsgStream.FreeStream;
  MsgStream.Stream := TMemoryStream.Create;
  MsgStream.bsInitForNewStream;                                        {!!.02}
end;

{ Clear all and create new empty message stream }
procedure TIpMessage.NewMessage;
begin
  Clear;
  NewMessageStream;
end;

{ Position property read access method }
function TIpMessage.GetPosition : Longint;
begin
  if Assigned(MsgStream) then
    Result := MsgStream.Position
  else
    Result := 0;
end;

{ Size property read access method }
function TIpMessage.GetSize : Longint;
begin
  if Assigned(MsgStream) then
    Result := MsgStream.Size
  else
    Result := 0;
end;

{ Return next line from the message stream (CRLF stripped) }
function TIpMessage.ReadLine : string;
begin
  if Assigned(MsgStream) then
    Result := MsgStream.ReadLine
  else
    Result := '';
end;

{ Return next line from the message stream (CRLF retained) }
function TIpMessage.ReadLineCRLF : string;
begin
  if Assigned(MsgStream) then
    Result := MsgStream.ReadLine + CRLF
  else
    Result := '';
end;

{- Save raw message stream to file }
procedure TIpMessage.SaveToFile(const aFileName : string);
var
  FS : TFileStream;
begin
  EncodeMessage;
  Position := 0;
  FS := TFileStreamUTF8.Create(aFileName, fmCreate);
  try
    FS.CopyFrom(MsgStream, MsgStream.Size);
  finally
    FS.Free;
  end;
end;

{Begin !!.12}
{- Save raw message stream }
procedure TIpMessage.SaveToStream(Stream: TStream);
begin
  Position := 0;
  Stream.CopyFrom(MsgStream, MsgStream.Size);
end;

procedure TIpMessage.SetHeaders(Headers : TIpHeaderCollection);
begin
  FHeaders.Assign(Headers);
end;
{End !!.12}

{ Position property write access method }
procedure TIpMessage.SetPosition(Value : Longint);
begin
  if Assigned(MsgStream) then
    MsgStream.Position := Value;
end;

{ Write string onto the message stream and append CRLF terminator }
procedure TIpMessage.WriteLine(const aSt : string);
begin
  if Assigned(MsgStream) then
    MsgStream.WriteLine(aSt);
end;

{ Indicates whether or not we're at the end of the message stream }
function TIpMessage.AtEndOfStream : Boolean;
begin
  if Assigned(MsgStream) then
    Result := MsgStream.AtEndOfStream
  else
    Result := True;
end;

{ Return 'alternative' text/plain mime part }
function TIpMessage.GetBodyPlain(CanCreate : Boolean) : TIpMimeEntity;
var
  aParent : TIpMimeEntity;
begin
  aParent := FindNestedMimePart(strMultipart, strAlternative, '');   {!!.02}
  if not Assigned(aParent) then
    aParent := Self;
{Begin !!.15}
  Result := aParent.FindNestedMimePart(strText, strPlain, '');
  if (Result = nil) and CanCreate then begin
    Result := NewMimePart;
    Result.ContentType := strText;
    Result.ContentSubtype := strPlain;
  end;
{End !!.15}
end;

{ Return 'alternative' text/html mime part }
function TIpMessage.GetBodyHtml(CanCreate : Boolean) : TIpMimeEntity;
var
  aParent : TIpMimeEntity;
begin
  aParent := FindNestedMimePart(strMultipart, strAlternative, '');   {!!.02}
  if not Assigned(aParent) then
    aParent := Self;
{Begin !!.15}
  Result := aParent.FindNestedMimePart(strText, strHtml, '');
  if (Result = nil) and CanCreate then begin
    Result := NewMimePart;
    Result.ContentType := strText;
    Result.ContentSubtype := strHTML;
  end;
{End !!.15}
end;

{ Add a file attachment using default types }
procedure TIpMessage.AddDefaultAttachment(const aFileName: string);     {!!.02}
begin
  with NewMimePart do begin
    EntityName := ExtractFileName(aFileName);
    ContentDispositionType := 'attachment';
    EncodeBodyFile(aFileName);
  end;
end;

procedure TIpMessage.AddDefaultAttachmentAs (const aFileName      : string;  {!!.12}
                                             const AttachmentName : string); {!!.12}
begin                                                                    {!!.12}
  with NewMimePart do begin                                              {!!.12}
    EntityName := ExtractFileName (AttachmentName);                      {!!.12}
    ContentDispositionType := 'attachment';                              {!!.12}
    EncodeBodyFile (aFileName);                                          {!!.12}
  end;                                                                   {!!.12}
end;                                                                     {!!.12}

{ Set message properties from another TIpMessage }
procedure TIpMessage.Assign(Source: TPersistent);
var
  SourcePos : Integer;
  SourceMsg : TIpMessage;
begin
  if Source is TIpMessage then begin
    SourceMsg := TIpMessage(Source);
    { clear our streams and properties }
    NewMessage;
    { ensure we are at the beginning of our streams }
    Position := 0;
    SourcePos := SourceMsg.Position;
    SourceMsg.Position := 0;
    MsgStream.CopyFrom(SourceMsg.MsgStream, 0);
    Position := 0;
    SourceMsg.Position := SourcePos;
    try                                                                {!!.03}
      DecodeMessage;
    except                                                             {!!.03}
      { just eat the exception, the messge might be corrupt, but the }
      { raw text (MessageStream property) will still be available    }
    end;                                                               {!!.03}
  end else
    inherited Assign(Source);
end;

procedure TIpMessage.SetBCC(const Value: TStringList);                 {!!.01}
begin
  FBCC.Assign(Value);
end;

procedure TIpMessage.SetCC(const Value: TStringList);                  {!!.01}
begin
  FCC.Assign(Value);
end;

procedure TIpMessage.SetNewsgroups(const Value: TStringList);          {!!.01}
begin
  FNewsgroups.Assign(Value);
end;

procedure TIpMessage.SetPath(const Value: TStringList);                {!!.01}
begin
  FPath.Assign(Value);
end;

procedure TIpMessage.SetReceived(const Value: TStringList);            {!!.01}
begin
  FReceived.Assign(Value);
end;

procedure TIpMessage.SetRecipients(const Value: TStringList);          {!!.01}
begin
  FRecipients.Assign(Value);
end;

procedure TIpMessage.SetReferences(const Value: TStringlist);          {!!.01}
begin
  FReferences.Assign(Value);
end;

procedure TIpMessage.SetUserFields(const Value: TStringList);          {!!.01}
begin
  FUserFields.Assign(Value);
end;



{ TIpFormDataEntity }
constructor TIpFormDataEntity.Create(ParentEntity : TIpMimeEntity);
begin
  inherited Create(ParentEntity);
  ContentType := strMultipart;
  ContentSubType := strFormData;
  Boundary := GenerateBoundary;
end;

destructor TIpFormDataEntity.Destroy;
begin
  inherited Destroy;
end;

{ Add file as nested Mime part of FilesEntity block }
procedure TIpFormDataEntity.AddFile(const aFileName,
                                    aContentType,
                                    aSubtype : string;
                                    aEncoding : TIpMimeEncodingMethod);
var
  Blk : TIpMimeEntity;
  MS : TIpMemMapStream;
begin
  if not Assigned(FFilesEntity) then begin
    FFilesEntity := NewMimePart;
    FFilesEntity.EntityName := strFiles;
    FFilesEntity.ContentDispositionType := strFormData;
    FFilesEntity.ContentType := strMultipart;
    FFilesEntity.ContentSubtype := strMixed;
  end;

  Blk := FFilesEntity.NewMimePart;
  Blk.ContentDispositionType := strAttachment;
  Blk.ContentType := aContentType;
  Blk.ContentSubtype := aSubtype;
  Blk.ContentTransferEncoding := aEncoding;

  MS := TIpMemMapStream.Create(aFileName, True, False);
  try
    MS.Open;
    Blk.EncodeBodyStream(MS, aFileName);
  finally
    MS.Free;
  end;
end;

{ Add FormData Mime part }
procedure TIpFormDataEntity.AddFormData(const aName, aText : string);
var
  Blk : TIpMimeEntity;
begin
  Blk := NewMimePart;
  Blk.EntityName := aName;
  Blk.ContentDispositionType := strFormData;
  Blk.Body.WriteLine(aText);
end;

{ Generate raw Mime message and save to stream }
procedure TIpFormDataEntity.SaveToStream(aStream : TStream);
var
  TS : TIpAnsiTextStream;
  SL : TStringList;
begin
  TS := TIpAnsiTextStream.Create(aStream);
  try
    SL := TStringList.Create;
    try
      EncodeMimeHeaders(SL);
      SL.SaveToStream(TS);
      EncodeEntity(TS);
    finally
      SL.Free;
    end;
  finally
    TS.Free;
  end;
end;

{HTTP Authentication Support -- .02}
function IpBase64EncodeString(const InStr: string): string;              {!!.03}
{
encode a string into Base64, intended for producing short ( < 100 chars or so)
coded strings to be passed as part of HTTP authentications via HTTP headers.

NO LINE ORIENTED SMARTS: if you need to work with blocks of text use the
IpMsg class
}
var
  CvtBuff: PChar;
  I, Ct, Count, OutLen: Cardinal;

function CodeByte(byt : Byte) : char;
{- encode 6-bit value to BinHex char and send it }
begin
  Result := Ip64Table[byt and $3F];
end;

begin
  Result := '';
  Count := Length(InStr);
  if Count = 0 then // empty input string nothing to encode              {!!.03}
    Exit;                                                                {!!.03}
  OutLen := Count * 2; // leave plenty of room for encoded string        {!!.03}
  GetMem(CvtBuff, OutLen + 1);

  Ct := 0;
  I := 1;

  if Count >= 3 then begin                                               {!!.03}
    while I <= (Count - 2) do begin
      { Encode 1st byte }
      CvtBuff[Ct] := CodeByte(Ord(InStr[I]) shr 2);
      Inc(Ct);

      { Encode 1st/2nd byte }
      CvtBuff[Ct]  := CodeByte((Ord(InStr[I]) shl 4) or (Ord(InStr[I+1]) shr 4));
      Inc(Ct);

      { Encode 2nd/3rd byte }
      CvtBuff[Ct] := CodeByte((Ord(InStr[I+1]) shl 2) or (Ord(InStr[I+2]) shr 6));
      Inc(Ct);

      { Encode 3rd byte }
      CvtBuff[Ct] := CodeByte(Ord(InStr[I+2]) and $3F);
      Inc(Ct);

      Inc(I, 3);
    end;
  end;                                                                   {!!.03}

  { Are there odd bytes to add? }
  if (I <= Count) then begin
    CvtBuff[Ct] := CodeByte(Ord(InStr[I]) shr 2);
    Inc(Ct);

    { One odd byte }
    if I = Count then begin
      CvtBuff[Ct] := CodeByte((Ord(InStr[I]) shl 4) and $30);
      Inc(Ct);
      CvtBuff[Ct] := '='; // pad char
      Inc(Ct);
    { Two odd bytes }
    end else begin
      CvtBuff[Ct] := CodeByte(((Ord(InStr[I]) shl 4) and $30)
        or ((Ord(InStr[I+1]) shr 4) and $0F));
      Inc(Ct);
      CvtBuff[Ct] := CodeByte((Ord(InStr[I+1]) shl 2) and $3C);
      Inc(Ct);
    end;
    { Add padding }
      CvtBuff[Ct] := '=';
      Inc(Ct);
  end;

  CvtBuff[Ct] := #0;
  Result := StrPas(CvtBuff);
  FreeMem(CvtBuff, OutLen + 1);
end;


end.