clencoder.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clEncoder;

interface

{$I clVer.inc}
{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
{$ENDIF}

uses
  SysUtils, Classes;

const
  DefaultCharsPerLine = 76;
  
type
  EclEncoderError = class(Exception);

  TclEncoderProgressEvent = procedure (Sender: TObject; ABytesProceed, ATotalBytes: Integer) of object;

  TclEncodeMethod = (cmNone, cmMIMEQuotedPrintable, cmMIMEBase64, cmUUEncode, cm8Bit);

  TclEncoder = class(TComponent)
  private
    FMethod: TclEncodeMethod;
    FCharsPerLine: Integer;
    FFirstPass,
    FDelimPresent,
    FStringProcessed,
    FSuppressCrlf: Boolean;
    FOnProgress: TclEncoderProgressEvent;
    function GetCorrectCharsPerLine: Integer;
    procedure DoProgress(ABytesProceed, ATotalBytes: Integer);
    function ReadOneLine(AStream: TStream; var Eof: Boolean; var crlfSkipped: Integer): string;
    function EncodeUUE(ASource, ADestination: TStream): Boolean;
    function DecodeUUE(ASource, ADestination: TStream): Boolean;
    function EncodeBASE64(ASource, ADestination: TStream): Boolean;
    function DecodeBASE64(ASource, ADestination: TStream): Boolean;
    function EncodeQP(ASource, ADestination: TStream): Boolean;
    function DecodeQP(ASource, ADestination: TStream): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    function GetNeedEncoding(ASource: TStream): TclEncodeMethod; overload;
    function GetNeedEncoding(ASource: string): TclEncodeMethod; overload;
    procedure EncodeStream(ASource, ADestination: TStream; AMethod: TclEncodeMethod);
    procedure DecodeStream(ASource, ADestination: TStream; AMethod: TclEncodeMethod);
    procedure EncodeString(const ASource: string; var ADestination: string; AMethod: TclEncodeMethod);
    procedure DecodeString(const ASource: string; var ADestination: string; AMethod: TclEncodeMethod);
    procedure EncodeToString(ASource: TStream; var ADestination: string; AMethod: TclEncodeMethod);
    procedure DecodeFromString(const ASource: string; ADestination: TStream; AMethod: TclEncodeMethod);
  published
    property CharsPerLine: Integer read FCharsPerLine write FCharsPerLine default DefaultCharsPerLine;
    property SuppressCrlf: Boolean read FSuppressCrlf write FSuppressCrlf default False;
    property OnProgress: TclEncoderProgressEvent read FOnProgress write FOnProgress;
  end;
 
{$IFDEF DEMO}
{$IFNDEF IDEDEMO}
var
  IsEncoderDemoDisplayed: Boolean = False;
{$ENDIF}
{$ENDIF}

resourcestring
  SclErrorUnsupported = 'Unsupported format.';
  SclErrorWrongSymbols = 'Wrong symbols in source stream.';
  
implementation

{$IFDEF DEMO}
uses
  Windows, Forms;
{$ENDIF}

const
  CR  = #13;
  LF  = #10;
  CRLF = CR + LF;
  MaxUUECharsPerLine = 132;
  MaxQPCharsPerLine = 132;
  MinBASE64CharsPerLine = 76;
  Base64CodeTable: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  Base64CodeTableEx: array[0..255] of Integer =
        ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$3f,$00,$00,$00,$40
        ,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$00,$00,$00,$00,$00,$00,$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,$1a,$00,$00,$00,$00,$00
        ,$00,$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,$34,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
        ,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);

procedure clEncoderError(const Msg: string);
begin
  raise EclEncoderError.Create(Msg);
end;

{ TclEncoder }

constructor TclEncoder.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCharsPerLine := DefaultCharsPerLine;
  FStringProcessed := False;
  FSuppressCrlf := False;
end;

function TclEncoder.GetNeedEncoding(ASource: string): TclEncodeMethod;
var
  SourceStream: TStream;
begin
  SourceStream := TMemoryStream.Create;
  try
    SourceStream.Write(PChar(ASource)^, Length(ASource));
    SourceStream.Position := 0;
    Result := GetNeedEncoding(SourceStream);
  finally
    SourceStream.Free;
  end;
end;

function TclEncoder.GetNeedEncoding(ASource: TStream): TclEncodeMethod;
var
  NonTransportable,
  MaxNonTransportable: Integer;
  Symbol: Char;
  CharPerLine: Integer;
begin
  NonTransportable := 0;
  CharPerLine := 0;
  MaxNonTransportable := ASource.Size div 2;
  Result := cmNone;
  while(ASource.Read(Symbol, 1) = 1) do
  begin
    case Ord(Symbol) of
      13,10:
        begin
          if(CharPerLine > 76) then
            Result := cmMIMEQuotedPrintable;
          CharPerLine := 0;
        end;
      0..9,11..12,14..31:
        begin
          Result := cmMIMEBase64;
          CharPerLine := 0;
          Break;
        end;
      32..126:
        begin
          Inc(CharPerLine);
        end;
      127..255:
        begin
          Result := cmMIMEQuotedPrintable;
          Inc(NonTransportable);
          if (MaxNonTransportable < NonTransportable) then
          begin
            Result := cmMIMEBase64;
            Break;
          end;
        end;
    end;
  end;
  if(CharPerLine > 76) and (Result = cmNone) then
  begin
    Result := cmMIMEQuotedPrintable;
  end;
end;

procedure TclEncoder.EncodeStream(ASource, ADestination: TStream; AMethod: TclEncodeMethod);
var
  EncodeFurther: Boolean;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if not IsEncoderDemoDisplayed then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  if (ASource.Size = 0) then Exit;

  FFirstPass := True;
  DoProgress(0, ASource.Size);
  EncodeFurther := False;
  FMethod := AMethod;
  repeat
    case FMethod of
      cmMIMEQuotedPrintable: EncodeFurther := EncodeQP(ASource, ADestination);
      cmMIMEBase64:          EncodeFurther := EncodeBASE64(ASource, ADestination);
      cmUUEncode:            EncodeFurther := EncodeUUE(ASource, ADestination);
      cmNone, cm8Bit:                ADestination.CopyFrom(ASource, ASource.Size);
      else clEncoderError(SclErrorUnsupported);
    end;
    DoProgress(ASource.Position, ASource.Size);
  until not EncodeFurther;
end;

procedure TclEncoder.DecodeStream(ASource, ADestination: TStream; AMethod: TclEncodeMethod);
var
  DecodeFurther: Boolean;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if not IsEncoderDemoDisplayed then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  if (ASource.Size = 0) then Exit;

  DoProgress(0, ASource.Size);
  FDelimPresent := False;
  DecodeFurther := False;
  FMethod := AMethod;
  repeat
    case FMethod of
      cmMIMEQuotedPrintable: DecodeFurther := DecodeQP(ASource, ADestination);
      cmMIMEBase64:          DecodeFurther := DecodeBASE64(ASource, ADestination);
      cmUUEncode:            DecodeFurther := DecodeUUE(ASource, ADestination);
      cmNone, cm8Bit:                ADestination.CopyFrom(ASource, ASource.Size);
      else clEncoderError(SclErrorUnsupported);
    end;
    DoProgress(ASource.Position, ASource.Size);
  until not DecodeFurther;
end;

procedure TclEncoder.EncodeString(const ASource: string; var ADestination: string; AMethod: TclEncodeMethod);
var
  SourceStream: TStream;
  DestinationStream: TStream;
begin
  SourceStream := nil;
  DestinationStream := nil;
  try
    SourceStream := TMemoryStream.Create();
    SourceStream.WriteBuffer(PChar(ASource)^, Length(ASource));
    DestinationStream := TMemoryStream.Create();
    FStringProcessed := True;
    SourceStream.Position := 0;
    EncodeStream(SourceStream, DestinationStream, AMethod);
    SetLength(ADestination, DestinationStream.Size);
    DestinationStream.Position := 0;
    DestinationStream.ReadBuffer(PChar(ADestination)^, DestinationStream.Size);
  finally
    SourceStream.Free();
    DestinationStream.Free();
    FStringProcessed := False;
  end;
end;

procedure TclEncoder.DecodeString(const ASource: string; var ADestination: string; AMethod: TclEncodeMethod);
var
  SourceStream: TStream;
  DestinationStream: TStream;
begin
  SourceStream := nil;
  DestinationStream := nil;
  try
    SourceStream := TMemoryStream.Create();
    SourceStream.WriteBuffer(PChar(ASource)^, Length(ASource));
    DestinationStream := TMemoryStream.Create();
    SourceStream.Position := 0;
    DecodeStream(SourceStream, DestinationStream, AMethod);
    SetLength(ADestination, DestinationStream.Size);
    DestinationStream.Position := 0;
    DestinationStream.ReadBuffer(PChar(ADestination)^, DestinationStream.Size);
  finally
    SourceStream.Free();
    DestinationStream.Free();
  end;
end;

function TclEncoder.EncodeBASE64(ASource, ADestination: TStream): Boolean;

  procedure ConvertToBase64(ASymbolsArray: PChar; ACount: Integer);
  var
    Symb,
    i: Integer;
  begin
    for i := 0 to ACount - 1 do
    begin
      Symb := Integer(ASymbolsArray[i]);
      case Symb of
        64: ASymbolsArray[i] := Char(13);
        65: ASymbolsArray[i] := Char(10);
        0..63: ASymbolsArray[i] := Base64CodeTable[Symb + 1];
      else
        ASymbolsArray[i] := '=';
      end;
    end;
  end;

var
  Buffer: PChar;
  OutBuffer: PChar;
  i,
  Completed,
  Length,
  LineLength,
  RestLength,
  InIndex, OutIndex: Integer;
begin
  Result := False;
  if FSuppressCrlf then
  begin
    LineLength := ASource.Size;
  end else
  begin
    LineLength := Trunc(GetCorrectCharsPerLine() * 3/4);
  end;
  Completed := ASource.Size;
  if (Completed = 0) then Exit;
  Length := (((Completed div 3)*4) div LineLength) * (LineLength + 2);
  if (Length = 0) then Length := LineLength + 2;
  Length := (Length + ($2000 - 1)) and not ($2000 - 1);
  GetMem(Buffer, Completed + 1);
  GetMem(OutBuffer, Length);
  try
    ASource.Read(Buffer^, Completed);
    Buffer[Completed] := #0;
    OutIndex := 0;
    InIndex := 0;
    repeat
      if not (FSuppressCrlf or FFirstPass) then
      begin
        OutBuffer[OutIndex] := Char(64);
        OutBuffer[OutIndex + 1] := Char(65);
        Inc(OutIndex, 2);
      end;
      FFirstPass := False;
      RestLength := Completed - InIndex;
      if (RestLength > LineLength) then RestLength := LineLength;
      for i := 0 to (RestLength div 3) - 1 do
      begin
        OutBuffer[OutIndex] := Char(Word(Buffer[InIndex]) shr 2);
        OutBuffer[OutIndex + 1] := Char(((Word(Buffer[InIndex]) shl 4) and 48) or ((Word(Buffer[InIndex + 1]) shr 4) and 15));
        OutBuffer[OutIndex + 2] := Char(((Word(Buffer[InIndex + 1]) shl 2) and 60) or ((Word(Buffer[InIndex + 2]) shr 6) and 3));
        OutBuffer[OutIndex + 3] := Char(Word(Buffer[InIndex + 2]) and 63);
        Inc(InIndex, 3);
        Inc(OutIndex, 4);
      end;
      if (RestLength mod 3) > 0 then
      begin
        OutBuffer[OutIndex] := Char(Word(Buffer[InIndex]) shr 2);
        OutBuffer[OutIndex + 1] := Char(((Word(Buffer[InIndex]) shl 4) and 48) or ((Word(Buffer[InIndex + 1]) shr 4) and 15));
        if((RestLength mod 3) = 1) then
        begin
          OutBuffer[OutIndex + 2] := Char(-1);//'=';
          OutBuffer[OutIndex + 3] := Char(-1);//'=';
        end else
        begin
          OutBuffer[OutIndex + 2] := Char(((Word(Buffer[InIndex + 1]) shl 2) and 60) or ((Word(Buffer[InIndex + 2]) shr 6) and 3));
          OutBuffer[OutIndex + 3] := Char(-1);//'=';
        end;
        Inc(InIndex, 3);
        Inc(OutIndex, 4);
      end;
    until not(InIndex < Completed);
    ConvertToBase64(OutBuffer, OutIndex);
    ADestination.Write(OutBuffer^, OutIndex);
  finally
    FreeMem(OutBuffer);
    FreeMem(Buffer);
  end;
end;

function TclEncoder.DecodeBASE64(ASource, ADestination: TStream): Boolean;
var
  Buffer: PChar;
  DestBuffer: PChar;
  CharCode,
  i, Completed,
  Index, OutIndex, TmpIndex,
  StrLength: Integer;
begin
  Result := False;
  Completed := ASource.Size;
  if (Completed = 0) then Exit;
  GetMem(Buffer, Completed);
  GetMem(DestBuffer, Completed);
  try
    ASource.Read(Buffer^, Completed);
    StrLength := 0;
    OutIndex := 0;
    for Index := 0 to Completed - 1 do
    begin
      if ((Buffer[Index] in ['=', CR, LF]) or (Index = (Completed - 1))) then
      begin
        if (Index = (Completed - 1)) and not (Buffer[Index] in ['=', CR, LF]) then
        begin
          CharCode := Base64CodeTableEx[Integer(Buffer[Index])] - 1;
          if (CharCode < 0) then
            clEncoderError(SclErrorWrongSymbols);
          DestBuffer[Index] := Char(CharCode);
          Inc(StrLength);
          TmpIndex := Index - StrLength + 1;
        end else
        begin
          TmpIndex := Index - StrLength;
        end;
        for i := 0 to (StrLength div 4) - 1 do
        begin
          DestBuffer[OutIndex] := Chr((Word(DestBuffer[TmpIndex]) shl 2) or (Word(DestBuffer[TmpIndex + 1]) shr 4));
          DestBuffer[OutIndex + 1] := Chr((Word(DestBuffer[TmpIndex + 1]) shl 4) or (Word(DestBuffer[TmpIndex + 2]) shr 2));
          DestBuffer[OutIndex + 2] := Chr((Word(DestBuffer[TmpIndex + 2]) shl 6) or (Word(DestBuffer[TmpIndex + 3])));
          Inc(TmpIndex, 4);
          Inc(OutIndex, 3);
        end;
        if (StrLength mod 4) > 0 then
        begin
          DestBuffer[OutIndex] := Chr((Word(DestBuffer[TmpIndex]) shl 2) or (Word(DestBuffer[TmpIndex + 1]) shr 4));
          DestBuffer[OutIndex + 1] := Chr((Word(DestBuffer[TmpIndex + 1]) shl 4) or (Word(DestBuffer[TmpIndex + 2]) shr 2));
          Inc(OutIndex, (StrLength mod 4)-1);
        end;
        StrLength := 0;
        if (Buffer[Index] = '=') then
        begin
          Break;
        end;
      end else
      begin
        CharCode := Base64CodeTableEx[Integer(Buffer[Index])] - 1;
        if (CharCode < 0) then
          clEncoderError(SclErrorWrongSymbols);
        DestBuffer[Index] := Char(CharCode);
        Inc(StrLength);
      end;
    end;
    ADestination.Write(DestBuffer^, OutIndex);
  finally
    FreeMem(DestBuffer);
    FreeMem(Buffer);
  end;
end;

function TclEncoder.EncodeQP(ASource, ADestination: TStream): Boolean;
var
  Symbol, Symbol1: Char;
  i: Integer;
  Code: Integer;
  SoftBreak: Boolean;
begin
  ADestination.Size := 0;
  ADestination.Position := 0;
  repeat
    Result := True;
    SoftBreak := True;
    i := 0;