lhsz.pas

cipher 5.1。一个几乎包含了所有常见的加密算法的控件

{Copyright:      Hagen Reddmann HaReddmann at T-Online dot de
 Author:         Hagen Reddmann
                 public domain, this Copyright must be included unchanged
 known Problems: none
 Version:        5.1,  Part I from Delphi Encryption Compendium  ( DEC Part I)
                 Delphi 5
 Description:    very small and effizient LHSS compression
                 with RC4 like encryption and 32 Bit Checksum
 Remarks:        LHEncodeBuffer() and LHDecodeBuffer() parameter out Data: Pointer
                 MUST be released with FreeMem(Data) by the caller !
                 The interface here works only on one linear chunk of input and
                 process this in one single step. But processing of sequential
                 chunks are possible with LHDeflate() and LHInflate(). Look into
                 LHEncode() and LHDecode() to see some right initialization.
                 Without Encryption the minimal compressable input should be > 10 Bytes.
                 With Encryption the minimal compressable input should be > 13 Bytes.
                 Below these limits the output is larger as the input.

 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ''AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
 * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}
unit LHSZ;
{$D-,L-,Y-,C-,O+}

{$DEFINE LHEncode}  // include compression code
{$DEFINE LHDecode}  // include decompression code
{$DEFINE LHCrypt}   // include encryption code

interface

const
  LH_ErrProtected   = -9;  // compressed Data are Password protected
  LH_ErrPassword    = -8;  // bad Password in Decoding
  LH_ErrCRC         = -7;  // bad CRC or decompressed Data detected ( Decode only)
  LH_ErrInflate     = -6;  // error in decode
  LH_ErrWrite       = -5;  // write error in Method WriteProc
  LH_ErrRead        = -4;  // read error in Method RreadProc
  LH_ErrInit        = -3;  // error in initialization phase
  LH_ErrAlloc       = -2;  // can't allocated memory
  LH_ErrGeneric     = -1;  // unspecific error

  LH_Ready          =  0;  // all ok

// Compression Mode Flags
  LH_TypeMask       = $FF00;
  LH_ModeMask       = $00FF;

  LH_Auto           = $0000;

// mode flags
  LH_Fastest        = $0001;
  LH_Fast           = $0020;
  LH_Normal         = $0040;
  LH_High           = $0080;
  LH_Max            = $00FF;

// type flags
  LH_Text           = $0100;
  LH_Binary         = $0200;
  LH_Huffman        = $0400;


type
  TReadProc  = function(var Buffer; Count: Integer): Integer of object;
  TWriteProc = function(const Buffer; Count: Integer): Integer of object;

{$IFDEF LHEncode}
function LHEncode(const Password: String; ReadProc: TReadProc; WriteProc: TWriteProc; Size, Mode: Integer): Integer;
function LHEncodeBuffer(const Password: String; const Buffer; BufferSize: Integer; out Data: Pointer): Integer;
{$ENDIF}

{$IFDEF LHDecode}
function LHDecode(const Password: String; ReadProc: TReadProc; WriteProc: TWriteProc; Size: Integer): Integer;
function LHDecodeBuffer(const Password: String; const Buffer; BufferSize: Integer; out Data: Pointer): Integer;
{$ENDIF}

function LHCheck(Code: Integer): Integer; // raise exception if code is a error

implementation

uses SysUtils;
{ generated Codesizes with D3, only LHEncode, LHDecode are used, Bufferprocs ignored
  $DEFINES                         size in bytes
    LHEncode                          3.640
    LHEncode, LHCrypt                 4.256

    LHDecode                          2.404
    LHDecode, LHCrypt                 2.968

    LHEncode, LHDecode                5.148
    LHEncode, LHDecode, LHCrypt       6.104

  Datesizes are allways 0
}
{$ALIGN ON}
{$IFOPT O+}
  {$DEFINE UseASM}
{$ENDIF}

const
  LH_MinCopy        =       2;   { don't modify, except you increase}
  LH_MaxCopy        =     257;   { should be a power of two +1}
  LH_CodesPerRange  =   LH_MaxCopy - LH_MinCopy +1;

  LH_nil            =      -1;           { End of linked list marker}
  LH_HashBits       =      12;           { optimal }
  LH_HashSize       = 1 shl LH_HashBits; { Number of entries in hash table, should be }
  LH_HashMask       = LH_HashSize -1;    { Mask for hash key wrap }

{ Adaptive Huffman variables }

  LH_CodeBits       =      32;

  LH_CopyRanges     =      16;
//  (0, 2, 6, 14, 30, 62, 126, 254, 510, 1022, 2046, 4094, 8190, 16382, 32766, 65534, 131070, 262142, 524286);
// stored dynamicaly in TLHData.Range, so we need NO Datasegement for LHSZ

  LH_MaxSize        = 131070 + LH_MaxCopy;  // dependend from LH_CopyRange

  LH_Special        =     256;          { Command code, subcommands can be 0-255 }
  LH_SpecialINC     =       0;          { Subcommand, copy Range increment}
  LH_SpecialEOF     =       1;          { Subcommand, Terminate}
  LH_SpecialCRC     =       2;          { Subcommand, Checksum}

  LH_SpecialBITS    =       3;


  LH_FirstCode      =     257;          { First code for COPYING lengths }
  LH_MaxChar        = LH_FirstCode + LH_CopyRanges * LH_CodesPerRange -1;
  LH_MaxChar2       = LH_MaxChar * 2 +1;
  LH_Root           =       1;
  LH_BufSize        =    1024 * 4; { buffer size, must be a multiply of Sizeof(Integer) }

// LHState
  LH_Init           =  1;
  LH_Working        =  2;
  LH_Finish         =  3;


type
  PInteger = ^Integer;
  PByte    = ^Byte;
  PWord    = ^Word;

  PLHData = ^TLHData;
  TLHData = record
    Data: array[0..LH_BufSize -1] of Byte;   // IN for Deflate, OUT for Inflate
    Code: array[0..LH_BufSize -1] of Byte;   // OUT for Deflate, IN for Inflate

    CRCTable: array[0..255] of Integer;
    CRC: Integer;
// from here
    TextPos: Integer;

    DataPos: Integer;
    DataBytes: Integer;
    DataSize: Integer;

    CodeBits: Integer;
    CodeBitsCount: Integer;
    CodePos: Integer;
    CodeBytes: Integer;
    CodeSize: Integer;

    Flag: Integer;
    Text: array[0..LH_MaxSize + LH_MaxCopy] of Byte;
// upto here, don't change this order, we fillout these with zero in one step !

    State: Integer; // current State
    InputSize: Integer;
    Read: TReadProc;
    Write: TWriteProc;

{ Huffman tree }
    Range: array[0..LH_CopyRanges] of Integer;
    RangeCopy: Integer;
    RangeMax: Integer;

    FreqCum: Integer;
    FreqReset: Integer;
    Left: array[LH_Root..LH_MaxChar] of Word;
    Right: array[LH_Root..LH_MaxChar] of Word;
    Parent: array[LH_Root..LH_MaxChar2] of Word;
    Freq: array[LH_Root..LH_MaxChar2] of Word;
    Chars: array[Byte] of Integer;

{encryption, modified RC4 with 8Bit CBC Freedback and Datadependend SBox shuffeling}
{$IFDEF LHCrypt}
    PC4_T: array[0..255] of Byte;
    PC4_P: Integer;
    PC4_I: Byte;
    PC4_J: Byte;
    PC4_F: Byte;
{$ENDIF}

{LZSS data, beginning of deflate only datas}
    Head: array[0..LH_HashSize -1] of Integer;
    Tail: array[0..LH_HashSize -1] of Integer;
    Next: array[0..LH_MaxSize  -1] of Integer;
    Prev: array[0..LH_MaxSize  -1] of Integer;

    Mode: Integer; // LH_Mode Flags
    ResetPos: Integer;
    SearchMax: Integer;
    SearchDepth: Integer;
    TextLen: Integer;
    RangeDist: Integer;
    RangeLimit: Integer;
//    LastBytes: Integer;
//    OverBytes: Integer;

    CurPos: Integer;
    NewPos: Integer;
    Distance: Integer;
  end;

{$IFDEF LHDecode}
  PLHInflate = ^TLHInflate;
  TLHInflate = record
    Data: array[0..LH_BufSize -1] of Byte;   // IN for Deflate, OUT for Inflate
    Code: array[0..LH_BufSize -1] of Byte;   // OUT for Deflate, IN for Inflate

    CRCTable: array[0..255] of Integer;
    CRC: Integer;
// from here
    TextPos: Integer;

    DataPos: Integer;
    DataBytes: Integer;
    DataSize: Integer;

    CodeBits: Integer;
    CodeBitsCount: Integer;
    CodePos: Integer;
    CodeBytes: Integer;
    CodeSize: Integer;

    Flag: Integer;
    Text: array[0..LH_MaxSize + LH_MaxCopy] of Byte;
// upto here, don't change this order, we fillout these with zero in one step !

    State: Integer; // current State
    InputSize: Integer;
    Read: TReadProc;
    Write: TWriteProc;

{ Huffman tree }
    Range: array[0..LH_CopyRanges] of Integer;
    RangeCopy: Integer;
    RangeMax: Integer;

    FreqCum: Integer;
    FreqReset: Integer;

    Left: array[LH_Root..LH_MaxChar] of Word;
    Right: array[LH_Root..LH_MaxChar] of Word;
    Parent: array[LH_Root..LH_MaxChar2] of Word;
    Freq: array[LH_Root..LH_MaxChar2] of Word;

{encryption, modified RC4 with 8Bit CBC Freedback and Datadependend SBox shuffeling}
{$IFDEF LHCrypt}
    PC4_T: array[0..255] of Byte;
    PC4_P: Integer;
    PC4_I: Byte;
    PC4_J: Byte;
    PC4_F: Byte;
{$ENDIF}
  end;
{$ENDIF}

// procedures for deflation and inflation

procedure LHFill(Buffer: Pointer; Size: Integer); assembler; register;
asm
         PUSH  EDI
         MOV   EDI,EAX
         MOV   ECX,EDX
         SHR   ECX,2
         XOR   EAX,EAX
         REP   STOSD
         POP   EDI
end;

procedure LHInitCRC(LH: PLHData);
{$IFDEF UseASM}
asm
         PUSH  EBX
         MOV   [EAX].TLHData.CRC,0FFFFFFFFh
         ADD   EAX,OFFSET TLHData.CRCTable
         MOV   ECX,255
@@1:     MOV   EDX,ECX
         MOV   EBX,8
@@2:     SHR   EDX,1
         JNC   @@3
         XOR   EDX,0EDB88320h
@@3:     DEC   EBX
         JNZ   @@2
         MOV   [EAX + ECX * 4],EDX
         DEC   ECX
         JNL   @@1
         POP   EBX
end;
{$ELSE}
var
  I,J,V: Integer;
begin
  for I := 0 to 255 do
  begin
    V := I;
    for J := 0 to 7 do
      if V and 1 <> 0 then V := (V shr 1) xor Integer($EDB88320)
        else V := V shr 1;
    LH.CRCTable[I] := V;
  end;
  LH.CRC := Integer($FFFFFFFF);
end;
{$ENDIF}

function LHUpdateCRC(LH: PLHData; const Buffer; Size: Integer): Integer;
{$IFDEF UseASM}
asm
         PUSH  EBX
         PUSH  EDI
         XOR   EBX,EBX
         LEA   EDI,[EAX].TLHData.CRCTable
         MOV   EAX,[EAX].TLHData.CRC
         DEC   ECX
         JLE   @@2

@@1:     MOV   EBX,[EDX]
         INC   EDX
         XOR   EBX,EAX
         SHR   EAX,8
         MOVZX EBX,BL
         XOR   EAX,[EDI + EBX * 4]
         DEC   ECX
         JNL   @@1

@@2:     POP   EDI
         POP   EBX
end;
{$ELSE}
var
  P: ^Byte;
  C: Integer;
begin
  P := @Buffer;
  C := LH.CRC;
  while Size > 0 do
  begin
    Dec(Size);
    C := C shr 8 xor LH.CRCTable[(C xor P^) and $FF];
    Inc(P);
  end;
  Result := C;
end;
{$ENDIF}

{$IFDEF LHCrypt}
procedure LHInitCrypt(LH: PLHData; const Password: String);
var
  I,S,J: Integer;
  K: array[0..255] of Byte;
begin
  LH.PC4_P := 0;
  LH.PC4_I := 0;
  LH.PC4_J := 0;
  S := Length(Password);
  if S = 0 then Exit;
  J := 0;
  for I := 0 to 255 do
  begin
    LH.PC4_T[I] := I;
    K[I] := Byte(Password[I mod S +1]);
    J := (J + K[I] * 257) mod MaxInt +1;
  end;
  LH.PC4_P := J;
  LH.PC4_F := J shr 8;
  for I := 0 to 255 do
  begin
    J := (J + LH.PC4_T[I] + K[I]) and $FF;
    S := LH.PC4_T[I];
    LH.PC4_T[I] := LH.PC4_T[J];
    LH.PC4_T[J] := S;
  end;
end;
{$ENDIF}
// Huffman support

procedure LHInitHuffman(LH: PLHData);
var  { Initialize Huffman frequency tree }
  I: Integer;
begin
  LH.Range[0] := 0;
  for I := 1 to High(LH.Range) do
    LH.Range[I] := LH.Range[I -1] * 2 + 2;
  LH.FreqCum := LH_MaxChar2;
  LH.FreqReset := 20000;
  LHFill(@LH.Chars, SizeOf(LH.Chars));
  for I := LH_Root to LH_MaxChar2 do
  begin
    LH.Parent[I] := I shr 1;
    LH.Freq[I] := 1;
  end;
  for I := LH_Root to LH_MaxChar do
  begin
    LH.Left[I] := I * 2;
    LH.Right[I] := I * 2 + 1;
  end;
end;

procedure LHResetFrequency(LH: PLHData);
{$IFDEF UseASM}
asm
         PUSH  EBX
         PUSH  EDI
         PUSH  ESI

         LEA   ESI,[EAX].TLHData.Freq
         MOV   ECX,LH_MaxChar2 shr 1
         XOR   EDI,EDI

@@1:     MOV   EAX,[ESI]

         ADD   EAX,000010001h
         AND   EAX,0FFFEFFFEh
         SHR   EAX,1
         MOV   EDX,EAX
         MOV   [ESI],EAX
         SHR   EDX,16
         MOVZX EAX,AX
         ADD   EDI,EDX
         ADD   EDI,EAX

         DEC   ECX
         LEA   ESI,[ESI + 4]
         JNZ   @@1

// process last Word
         MOVZX EAX,Word Ptr [ESI]
         ADD   EAX,1
         AND   EAX,0FFFEh
         SHR   EAX,1
         MOV   [ESI],AX
         ADD   EDI,EAX
         MOV   [EBX].TLHData.FreqCum,EDI

         POP   ESI
         POP   EDI
         POP   EBX
end;
{$ELSE}
var
  I: Integer;
begin
  LH.FreqCum := 0;
  for I := LH_Root to LH_MaxChar2 do
  begin
    LH.Freq[I] := (LH.Freq[I] + 1) shr 1;
    Inc(LH.FreqCum, LH.Freq[I]);
  end;
end;
{$ENDIF}

procedure LHUpdateModel(LH: PLHData; Code: Integer);

  procedure LHUpdateFrequency(LH: PLHData; A,B: Integer);
  begin { Update frequency counts from leaf to root }
    repeat
      B := LH.Freq[A] + LH.Freq[B];
      A := LH.Parent[A];
      Inc(LH.FreqCum, B - LH.Freq[A]);
      LH.Freq[A] := B;
      if A <> LH_Root then
      begin
        B := LH.Parent[A];
        if LH.Left[B] <> A then B := LH.Left[B] else B := LH.Right[B];
      end else Break;
    until False;
  end;

var { Update Huffman model for each character code }
  A, B, C, X, Y: Integer;
begin
  Inc(LH.Chars[Code mod 256]);
  if LH.FreqCum > LH.FreqReset then
  begin
    C := 0;
    for X := 0 to 255 do
    begin
      if LH.Chars[X] > 0 then Inc(C);
      LH.Chars[X] := 0;//LH.Chars[X] shr 3;
    end;
    if (C < 64) and (LH.FreqReset > 14000) then
      Dec(LH.FreqReset, 1000)
    else
      if (C > 128) and (LH.FreqReset < 20000) then
        Inc(LH.FreqReset, 1000);
    LHResetFrequency(LH);
  end;
  A := Code + LH.RangeMax;