stmime.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** 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 SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StMime.pas 4.03                             *}
{*********************************************************}
{* SysTools: Internet Conversion unit for SysTools       *}
{*********************************************************}

{$I StDefine.inc}

{
Note: Some Mime routines rely on overflows for their results,
so these need to be off:
}
{$R-}
{$Q-}

unit StMime;

interface

uses
  Windows,
  SysUtils,
  Classes,
  StConst,
  StBase,
  StStrZ,
  StStrL,
  StOStr;

const
  AttachmentFileMode = (fmOpenRead or fmShareDenyWrite);
  CRLFStr : array[0..1] of Char = #13#10;
  DefStContentDisposition : string[11] = 'attachment';
  DefStContentType : string[27] = 'application/octet-stream';
  DefStMimeEncoding : string[7] = 'base64';
  ExtractFileMode = (fmOpenReadWrite or fmShareExclusive);
  MaxMimeLine = 78;

type

  TStConvertState = (csStarted, csProgressing, csFinished);

  TStProgressEvent =
    procedure(Sender : TObject; Status : TStConvertState; PercentDone : Byte) of object;

  TStSaveAsEvent = procedure(Sender : TObject; var FileName : string) of object;

{.Z+}
  TStMimeConverter = class;

  { Base conversion stream }
  TStConvertStream = class
  protected {private}
    FCurrentFile : string;
    FOwner : TStMimeConverter;
    FOnProgress : TStProgressEvent;
  public
    constructor Create(Owner : TStMimeConverter); virtual;
    procedure DecodeToStream(InStream, OutStream : TStream); virtual; abstract;
    procedure EncodeToStream(InStream, OutStream : TStream); virtual; abstract;
    procedure Progress(Status : TStConvertState; PercentDone : Byte); virtual;
    property CurrentFile : string
      read FCurrentFile write FCurrentFile;
    property OnProgress : TStProgressEvent
      read FOnProgress write FOnProgress;
  end;

  { Conversion stream for raw copying }
  TStRawStream = class(TStConvertStream)
  public
    constructor Create(Owner : TStMimeConverter); override;
    procedure DecodeToStream(InStream, OutStream : TStream); override;
    procedure EncodeToStream(InStream, OutStream : TStream); override;
  end;

  { Conversion stream for Quoted-Printable }
  TStQuotedStream = class(TStConvertStream)
  public
    constructor Create(Owner : TStMimeConverter); override;
    procedure DecodeToStream(InStream, OutStream : TStream); override;
    procedure EncodeToStream(InStream, OutStream : TStream); override;
  end;

  { Conversion stream for UUEncoding }
  TStUUStream = class(TStConvertStream)
  public
    constructor Create(Owner : TStMimeConverter); override;
    procedure DecodeToStream(InStream, OutStream : TStream); override;
    procedure EncodeToStream(InStream, OutStream : TStream); override;
  end;

  { Conversion stream for Base64 }
  TStBase64Stream = class(TStConvertStream)
  public
    constructor Create(Owner : TStMimeConverter); override;
    procedure DecodeToStream(InStream, OutStream : TStream); override;
    procedure EncodeToStream(InStream, OutStream : TStream); override;
  end;

{.Z-}

  TStConverterClass = class of TStConvertStream;

  TStAttachment = class
  protected {private}
    FContentDescription : string;
    FContentDisposition : string;
    FContentType : string;
    FEncoding : string;
    FFileName : string;
    FOldStyle : Boolean;
    FSize : LongInt;
    FStreamOffset : LongInt;
  public
    { Description of this attachment }
    property atContentDescription : string
      read FContentDescription write FContentDescription;

    { Disposition of this attachment }
    property atContentDisposition : string
      read FContentDisposition write FContentDisposition;

    { Content type of this attachment }
    property atContentType : string
      read FContentType write FContentType;

    { Encoding used for this attachment }
    property atEncoding : string
      read FEncoding write FEncoding;

    { Filename for this attachment }
    property atFilename : string
      read FFileName write FFileName;

    { Old style (non-mime) attachment }
    property atOldStyle : Boolean
      read FOldStyle write FOldStyle;

    { Size of attachment (in the unencoded state) }
    property atSize : LongInt
      read FSize write FSize;

    { Offset of attachment in message }
    property atStreamOffset : LongInt
      read FStreamOffset write FStreamOffset;
  end;

  TStMimeConverter = class
  protected {private}
    {.Z+}
    FAttachments : TStringList;
    FBoundary : string;
    FBoundaryUsed : Boolean;
    FContentDescription : string;
    FContentDisposition : string;
    FContentType : string;
    FConverter : TStConvertStream;
    FDirectory : string;
    FEncoding : string;
    FEndBoundaryOffset : LongInt;
    FMimeHeaders : Boolean;
    FStream : TStream;
    FInternalStream : TMemoryStream;
    FOnProgress : TStProgressEvent;
    FOnSaveAs : TStSaveAsEvent;
    procedure AddMimeFooters;
    procedure AddMimeHeaders(const AFileName : string);
    procedure DeleteAttachments;
    procedure ForceType(ConverterType : TStConverterClass);
    function GetBoundary : string;
    function GetStream : TStream;
    procedure InitConverter;
    procedure SetBoundary(Value : string);
    procedure SetConverter(Value : TStConvertStream);
    procedure SetEncoding(Value : string);
    procedure SetStream(Value : TStream);
    {.Z-}
  protected
    procedure FindOldAttachment;
    function GenerateBoundary : string; dynamic;
    procedure PositionForExtract(Att : TStAttachment); dynamic;
    procedure Progress(Sender : TObject; Status : TStConvertState;
      PercentDone : Byte); dynamic;
    procedure SaveAs(var FileName : string);
    procedure ScanAttachments;
  public
    constructor Create;
    constructor CreateInit(AStream : TStream); virtual;
    destructor Destroy; override;
    procedure AddFileAttachment(const AFileName : string);
    procedure AddStreamAttachment(AStream : TStream; const AFileName : string); dynamic;
    procedure ExtractAttachment(const Attachment : string); dynamic;
    procedure ExtractAttachmentIndex(Index : Integer); dynamic;
    procedure ExtractToStream(Index : Integer; AStream : TStream); dynamic;
    procedure ExtractAttachments;
    procedure FillConverterList(List : TStrings);
    function GetTag(const Description : string): string;
    class procedure RegisterConverter(const ATag, ADesc : string;
      AClass : TStConverterClass);
    class procedure UnRegisterConverterClass(AClass : TStConverterClass);

    { List of attachments in current stream }
    property Attachments : TStringList
      read FAttachments;

    { Boundary being used for attachments }
    property Boundary : string
      read GetBoundary write SetBoundary;

    { Default encoding to use for attachments }
    property Encoding : string
      read FEncoding write SetEncoding;

    { Default Content Description to use for attachments }
    property ContentDescription : string
      read FContentDescription write FContentDescription;

    { Default Content Disposition to use for attachments }
    property ContentDisposition : string
      read FContentDisposition write FContentDisposition;

    { Default Content Type to use for attachments }
    property ContentType : string
      read FContentType write FContentType;

    { Instance of converter to be used with current encoding method }
    property Converter : TStConvertStream
      read FConverter write SetConverter;

    { Default directory used for ExtractAttachments }
    property Directory : string
      read FDirectory write FDirectory;

    { Determines whether Mime boundaries/headers are added to attachments }
    property MimeHeaders : Boolean
      read FMimeHeaders write FMimeHeaders default True;

    { Access to internal stream }
    property Stream : TStream
      read GetStream write SetStream;

    { Progress event -- optional for converters to support this }
    property OnProgress : TStProgressEvent
      read FOnProgress write FOnProgress;

    { SaveAs event -- fired when extracting an attachment  }
    property OnSaveAs : TStSaveAsEvent
      read FOnSaveAs write FOnSaveAs;
  end;

implementation

const
  StUUTable : array[0..63] of Char = (#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
  St64Table : array[0..63] of Char = ( #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,  #97,  #98,  #99, #100, #101, #102, #103, #104, #105,
        #106, #107, #108, #109, #110, #111, #112, #113, #114, #115,
        #116, #117, #118, #119, #120, #121, #122,  #48,  #49,  #50,
         #51,  #52,  #53,  #54,  #55,  #56,  #57,  #43,  #47);

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


var
  CvtLock : TRTLCriticalSection;

type
  TStContentTag = (ctType, ctEncoding, ctDescription, ctDisposition);

  PStTernaryNode = ^TStTernaryNode;
  TStTernaryNode = record
    SplitChar : Char;
    LoKid, EqKid, HiKid : PStTernaryNode;
  end;

  TStTernaryTree = class
  private
    Root : PStTernaryNode;
    pData : Pointer;
    function Insert(P : PStTernaryNode; C : PChar) : PStTernaryNode;
    class procedure DeleteSubTree(Root : PStTernaryNode);
    function NewNode : PStTernaryNode;
  public
    destructor Destroy; override;
    procedure InsertStr(C : PChar; Data : Pointer);
    function SearchUC(C : PChar; var Data : Pointer) : Boolean;
  end;

{ TStTernaryTree }
class procedure TStTernaryTree.DeleteSubTree(Root : PStTernaryNode);
begin
  if Root <> nil then begin
    DeleteSubTree(Root^.LoKid);
    if Root^.SplitChar <> #0 then
      DeleteSubTree(Root^.EqKid);
    DeleteSubTree(Root^.HiKid);
    Dispose(Root);
  end;
end;

destructor TStTernaryTree.Destroy;
begin
  DeleteSubTree(Root);
  inherited Destroy;
end;

function TStTernaryTree.NewNode : PStTernaryNode;
begin
  Result := AllocMem(SizeOf(TStTernaryNode));
end;

function TStTernaryTree.Insert(P : PStTernaryNode; C : PChar) : PStTernaryNode;
begin
  if P = nil then begin
    P := NewNode;
    P^.SplitChar := C^;
    if C^ <> #0 then begin
      Inc(C);
      P^.EqKid := Insert(P^.EqKid,C);
    end else
      P^.EqKid := pData;
    Result := P;
    Exit;
  end;
  if C^ < P^.SplitChar then
    P^.LoKid := Insert(P^.LoKid,C)
  else if C^ = P^.SplitChar then
    if C^ <> #0 then begin
      Inc(C);
      P^.EqKid := Insert(P^.EqKid,C);
    end else
      RaiseStError(EStMimeError, stscDupeString)
  else
    P^.HiKid := Insert(P^.HiKid,C);
  Result := P;
end;

procedure TStTernaryTree.InsertStr(C : PChar; Data : Pointer);
begin
  pData := Data;
  Root := Insert(Root, C);
end;

function TStTernaryTree.SearchUC(C : PChar; var Data : Pointer) : Boolean;
var
  P : PStTernaryNode;
  CU : Char;
begin
  P := Root;
  while P <> nil do begin
    CU := UpCase(C^);
    if CU < P^.SplitChar then
      P := P^.LoKid
    else if CU = P^.SplitChar then begin
      Inc(C);
      if C^ = #0 then begin
        Data := P^.EqKid^.EqKid;
        Result := True;
        Exit;
      end;
      P := P^.EqKid;
    end else
      P := P^.HiKid;
  end;
  Result := False;
end;

{ TStConvertStream }
constructor TStConvertStream.Create(Owner : TStMimeConverter);
begin
  FOwner := Owner;
  inherited Create;
end;

procedure TStConvertStream.Progress(Status : TStConvertState; PercentDone : Byte);
begin
  if Assigned(FOnProgress) then
    OnProgress(Self, Status, PercentDone);
end;

{ TStRawStream }
constructor TStRawStream.Create(Owner : TStMimeConverter);
begin
  inherited Create(Owner);
end;

procedure TStRawStream.DecodeToStream(InStream, OutStream : TStream);
begin
  Progress(csStarted, 0);
  try
    OutStream.CopyFrom(InStream, InStream.Size-InStream.Position);     
  except
    Progress(csFinished, 0);
    raise;
  end;
  Progress(csFinished, 100);
end;

procedure TStRawStream.EncodeToStream(InStream, OutStream : TStream);
begin
  Progress(csStarted, 0);
  try
    OutStream.CopyFrom(InStream, InStream.Size);
  except
    Progress(csFinished, 0);