lhsz.pas

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

      begin
        LH.SearchMax   := (LH.Mode and LH_ModeMask -1) * 4 +2;
        LH.SearchDepth := (LH.Mode and LH_ModeMask -1) * 2;
      end;
      if LH.Mode and LH_ModeBIN = 0 then
      begin
        LH.SearchMax   := LH.SearchMax * 3;
        LH.SearchDepth := LH.SearchDepth * 2;
      end;
    end;
    if LH.Mode and LH_Huffman <> 0 then
      LH.Mode := LH.Mode or LH_ModeHuff;
  end else
    if (LH.State = LH_Working) and (LH.DataSize = 0) and not LHRead(LH) then Exit;

  if LH.State < LH_Working then Exit;

  repeat
    { Update nodes in hash table lists }
    if LH.Mode and LH_ModeHuff <> 0 then goto Huffman;

    if LH.Flag and LH_Full <> 0 then LHDeleteNode(LH, LH.TextPos);
    LHInsertNode(LH, LH.NewPos);
    if LH.Flag and LH_Found <> 0 then
    begin
      Dec(LH.TextLen);
      if LH.TextLen = 1 then
        LH.Flag := LH.Flag and not LH_Found;
    end else
    begin
      LH.TextLen := LHMatch(LH, False);
      if LH.TextLen >= LH_MinCopy then
      begin
        C := LHMatch(LH, True);
        if LH.TextLen >= C then
        begin
          if LH.Distance >= LH.RangeDist then
          begin
            LHUpdateRange(LH);
            if LH.Distance >= LH.RangeDist then goto Huffman;
          end;
          for C := 0 to LH.RangeCopy -1 do
            if LH.Distance < LH.Range[C +1] then
            begin
              LH.Flag := LH.Flag or LH_Found;
              LHCompress(LH, LH.TextLen - LH_MinCopy + LH_FirstCode + C * LH_CodesPerRange);
              LHWriteCode(LH, LH.Distance - LH.Range[C], C +1);
              if LH.State < LH_Ready then Exit
                else goto Skip;
            end;
        end;
      end;

Huffman:
      LHCompress(LH, LH.Text[LH.NewPos]);
    end;
Skip:

  { Advance buffer pointers }
    Inc(LH.NewPos); if LH.NewPos = LH_MaxSize then LH.NewPos := 0;
    Inc(LH.CurPos); if LH.CurPos = LH_MaxSize then LH.CurPos := 0;

  { Add next input character to buffer }
    if LH.DataSize > 0 then
    begin
      C := LH.Data[LH.DataPos];
      Inc(LH.DataPos);
      if (LH.DataPos >= LH.DataSize) and not LHRead(LH) then Exit;
      LH.Text[LH.TextPos] := C;
      if LH.TextPos <= LH_MaxCopy then LH.Text[LH_MaxSize + LH.TextPos] := C;
      Inc(LH.TextPos);

      if LH.TextPos = LH_MaxSize then
      begin
        LH.TextPos := 0;
        LH.Flag := LH.Flag or LH_Full;
      end;
      Inc(LH.DataBytes);
    end else
      if LH.State = LH_Finish then
      begin
        if LH.NewPos = LH.TextPos then
        begin
Finish:
          LHCompress(LH, LH_Special);
          LHWriteCode(LH, LH_SpecialCRC, LH_SpecialBITS);
          LHWriteCode(LH, not LH.CRC, 32);
          LHFlush(LH);
          LH.State := LH_Ready;
          Break;
        end;
      end else Break;
  until LH.State < LH_Ready;
end;

function LHEncode(const Password: String; ReadProc: TReadProc; WriteProc: TWriteProc; Size, Mode: Integer): Integer;
var
  LH: PLHData;
begin
  try
    GetMem(LH, SizeOf(TLHData));
  except
    Result := LH_ErrAlloc;
    Exit;
  end;
  try
    LH.State := LH_Init;
    LH.Mode := Mode;
    LH.Read := ReadProc;
    LH.Write := WriteProc;
    LH.InputSize := Size;
{$IFDEF LHCrypt}
    LHInitCrypt(LH, Password);
{$ENDIF}
    LHDeflate(LH);
  finally
    Result := LH.State;
    if Result >= LH_Ready then Result := LH.CodeBytes;
    LHFill(LH, SizeOf(TLHData));
    ReallocMem(LH, 0);
  end;
end;
{$ENDIF}

{$IFDEF LHDecode}
procedure LHInflate(LH: PLHData);
const
  LH_First = 4;

{$IFDEF LHCrypt}
  procedure LHCrypt(LH: PLHData; Size: Integer);
  var
    S,F: Byte;
    B: PByte;
  begin
    B := @LH.Code;
    if LH.Flag and LH_First = 0 then
    begin
      LH.Flag := LH.Flag or LH_First;
      if B^ and 1 = 0 then // test if data are encryted
      begin
        LH.PC4_P := 0;     // no, deactivate encryption
        LHFill(@LH.PC4_T, SizeOf(LH.PC4_T));
        Exit;
      end;
      Inc(B);
      Dec(Size);
    end;
    while Size > 0 do
    begin
      Dec(Size);
      Inc(LH.PC4_I);
      S := LH.PC4_T[LH.PC4_I];
      Inc(LH.PC4_J, S);
      LH.PC4_T[LH.PC4_I] := LH.PC4_T[LH.PC4_J] xor LH.PC4_F;
      LH.PC4_T[LH.PC4_J] := S - LH.PC4_F;
      F := B^;
      B^ := B^ xor LH.PC4_T[(LH.PC4_T[LH.PC4_I] + S) and $FF] - LH.PC4_F;
      LH.PC4_F := F;
      Inc(B);
    end;
  end;
{$ENDIF}

  function LHRead(LH: PLHData): Integer;
  var
    I: Integer;
  begin
    if LH.CodePos >= LH.CodeSize then
    begin
      LH.CodePos := 0;
      LH.CodeSize := SizeOf(LH.Code);
      if (LH.InputSize > 0) and (LH.CodeSize > LH.InputSize) then
        LH.CodeSize := LH.InputSize;
      if LH.CodeSize > 0 then
        LH.CodeSize := LH.Read(LH.Code, LH.CodeSize);
      if LH.CodeSize = 0 then LH.State := LH_Finish else
        if LH.CodeSize < 0 then
        begin
          LH.State := LH_ErrRead;
          Result := LH.State;
          Exit;
        end else
        begin
          if LH.InputSize > 0 then Dec(LH.InputSize, LH.CodeSize);
          I := LH.CodeSize;
          while I mod 4 <> 0 do
          begin
            LH.Code[I] := 0;
            Inc(I);
          end;
{$IFDEF LHCrypt}
          if LH.PC4_P <> 0 then LHCrypt(LH, LH.CodeSize);
{$ENDIF}
        end;
    end;
    LH.CodeBits := PInteger(@LH.Code[LH.CodePos])^;
    Inc(LH.CodePos, SizeOf(LH.CodeBits));
    Inc(LH.CodeBytes, SizeOf(LH.CodeBits));
    LH.CodeBitsCount := LH_CodeBits;
    Result := LH.State;
  end;

  function LHReadCode(LH: PLHData; Bits: Integer): Integer;
  var
    I: Integer;
  begin
    Result := 0;
    for I := 0 to Bits -1 do
    begin
      if (LH.CodeBitsCount = 0) and (LHRead(LH) < LH_Ready) then Exit;
      Dec(LH.CodeBitsCount);
      Result := Result or (LH.CodeBits and 1) shl I;
      LH.CodeBits := LH.CodeBits shr 1;
    end;
  end;

  function LHUncompress(LH: PLHData): Integer;
  begin
    Result := LH_Root;
    repeat
      if (LH.CodeBitsCount = 0) and (LHRead(LH) < LH_Ready) then Exit;
      Dec(LH.CodeBitsCount);
      if LH.CodeBits and 1 <> 0 then Result := LH.Right[Result]
        else Result := LH.Left[Result];
      LH.CodeBits := LH.CodeBits shr 1;
    until Result >= LH.RangeMax;
    Dec(Result, LH.RangeMax);
    LHUpdateModel(LH, Result);
  end;

  function LHWrite(LH: PLHData): Boolean;
  begin
    LH.DataSize := LH.Write(LH.Data, LH.DataPos);
    if LH.DataSize = LH.DataPos then LH.CRC := LHUpdateCRC(LH, LH.Data, LH.DataSize)
      else LH.State := LH_ErrWrite;
    LH.DataPos := 0;
    Result := LH.State >= LH_Ready;
  end;

var
  C, L, I: Integer;
begin
  if LH.State = LH_Init then
  begin
    LHFill(@LH.TextPos, 10 * 4);
    LH.State := LH_Working;

    LH.RangeCopy  := 12;
    LH.RangeMax  := LH_FirstCode + (LH.RangeCopy * LH_CodesPerRange);

    LHInitCRC(LH);
    LHInitHuffman(LH);
    C := LHReadCode(LH, 1);
    if C <> 0 then
{$IFDEF LHCrypt}
      if LH.PC4_P <> 0 then
      begin
        C := LHReadCode(LH, 16);
        if C shr 8 xor C and $FF <> LH.PC4_P and $FF then
        begin
          LH.State := LH_ErrPassword;
          Exit;
        end;
      end else
      begin
        LH.State := LH_ErrProtected;
        Exit;
      end;
{$ELSE}
      begin
        LH.State := LH_ErrProtected;
        Exit;
      end;
{$ENDIF}
  end;

  if LH.State < LH_Working then Exit else
    if LH.State = LH_Working then C := LHUncompress(LH)
      else C := 0;

  while LH.State = LH_Working do
  begin
    if C < LH_Special then
    begin
      LH.Data[LH.DataPos] := C;
      Inc(LH.DataPos);
      if (LH.DataPos >= SizeOf(LH.Data)) and not LHWrite(LH) then Exit;
      Inc(LH.DataBytes);
      LH.Text[LH.TextPos] := C;
      Inc(LH.TextPos); if LH.TextPos >= LH_MaxSize then LH.TextPos := 0;
    end else
      if C >= LH_FirstCode then
      begin
        Dec(C, LH_FirstCode);

        I := C div LH_CodesPerRange;
        L := C mod LH_CodesPerRange + LH_MinCopy;
        C := LH.TextPos - (LHReadCode(LH, I +1) + L + LH.Range[I]);

        if C < 0 then Inc(C, LH_MaxSize);
        if (C < 0) or (C >= LH_MaxSize) then LH.State := LH_ErrInflate;
        if LH.State < LH_Ready then Exit;

        repeat
          LH.Data[LH.DataPos] := LH.Text[C];
          Inc(LH.DataPos);
          if (LH.DataPos >= SizeOf(LH.Data)) and not LHWrite(LH) then Exit;
          LH.Text[LH.TextPos] := LH.Text[C];
          Inc(LH.TextPos); if LH.TextPos >= LH_MaxSize then LH.TextPos := 0;
          Inc(C); if C >= LH_MaxSize then C := 0;
          Inc(LH.DataBytes);
          Dec(L);
        until L = 0;
      end else
      begin
        C := LHReadCode(LH, LH_SpecialBITS);
        case C of
          LH_SpecialINC:
            if LH.RangeCopy < LH_CopyRanges then
            begin
              Inc(LH.RangeCopy);
              LH.RangeMax := LH_FirstCode + (LH.RangeCopy * LH_CodesPerRange);
            end else
            begin
              LH.State := LH_ErrInflate;
              Exit;
            end;
          LH_SpecialEOF:
            begin
              LH.State := LH_Finish;
              Break;
            end;
          LH_SpecialCRC:
            if not LHReadCode(LH, 32) <> LHUpdateCRC(LH, LH.Data, LH.DataPos) then
            begin
              LH.State := LH_ErrCRC;
              Exit;
            end else
            begin
              LH.State := LH_Finish;
              Break;
            end;
        else
          begin
            LH.State := LH_ErrInflate;
            Exit;
          end;
        end;
      end;
    C := LHUncompress(LH);
  end;

  if LH.State = LH_Finish then
  begin
    if (LH.DataPos > 0) and not LHWrite(LH) then Exit;
    if LH.State > LH_Ready then LH.State := LH_Ready;
  end;
end;

function LHDecode(const Password: String; ReadProc: TReadProc; WriteProc: TWriteProc; Size: Integer): Integer;
var
  LH: PLHData;
begin
  try
    GetMem(LH, SizeOf(TLHInflate));
  except
    Result := LH_ErrAlloc;
    Exit;
  end;
  try
    LH.State := LH_Init;
    LH.Read := ReadProc;
    LH.Write := WriteProc;
    LH.InputSize := Size;
{$IFDEF LHCrypt}
    LHInitCrypt(LH, Password);
{$ENDIF}
    LHInflate(LH);
  finally
    Result := LH.State;
    if Result >= LH_Ready then Result := LH.DataBytes;
    LHFill(LH, SizeOf(TLHInflate));
    ReallocMem(LH, 0);
  end;
end;
{$ENDIF}

// internal used in Buffer En/Decoding
type
  PLHCallbackRec = ^TLHCallbackRec;
  TLHCallbackRec = packed record
    Buffer: PChar;
    BufferSize: Integer;
    Data: PChar;
    DataSize: Integer;
  end;

  TMethod = record
    Code, Data: Pointer;
  end;

function LHGetRead(R: PLHCallbackRec): TReadProc;

  function DoRead(R: PLHCallbackRec; var Buffer; Count: Integer): Integer; register;
  begin
    if Count > R.BufferSize then Count := R.BufferSize;
    Move(R.Buffer^, Buffer, Count);
    Inc(R.Buffer, Count);
    Dec(R.BufferSize, Count);
    Result := Count;
  end;

begin
  TMethod(Result).Data := R;
  TMethod(Result).Code := @DoRead;
end;

function LHGetWrite(R: PLHCallbackRec): TWriteProc;

  function DoWrite(R: PLHCallbackRec; const Buffer; Count: Integer): Integer; register;
  begin
    ReallocMem(R.Data, R.DataSize + Count);
    Move(Buffer, R.Data[R.DataSize], Count);
    Inc(R.DataSize, Count);
    Result := Count;
  end;

begin
  TMethod(Result).Data := R;
  TMethod(Result).Code := @DoWrite;
end;

{$IFDEF LHEncode}
function LHEncodeBuffer(const Password: String; const Buffer; BufferSize: Integer; out Data: Pointer): Integer;
var
  R: TLHCallbackRec;
begin
  Data := nil;
  R.Buffer := @Buffer;
  R.BufferSize := BufferSize;
  R.Data := nil;
  R.DataSize := 0;
  try
    Result := LHEncode(Password, LHGetRead(@R), LHGetWrite(@R), BufferSize, LH_Max);
    if Result >= LH_Ready then
    begin
      Data := R.Data;
      Result := R.DataSize;
    end;
  except
    Result := LH_ErrGeneric;
    ReallocMem(R.Data, 0);
  end;
end;
{$ENDIF}

{$IFDEF LHDecode}
function LHDecodeBuffer(const Password: String; const Buffer; BufferSize: Integer; out Data: Pointer): Integer;
var
  R: TLHCallbackRec;
begin
  Data := nil;
  R.Buffer := @Buffer;
  R.BufferSize := BufferSize;
  R.Data := nil;
  R.DataSize := 0;
  try
    Result := LHDecode(Password, LHGetRead(@R), LHGetWrite(@R), BufferSize);
    if Result >= LH_Ready then
    begin
      Data := R.Data;
      Result := R.DataSize;
    end;
  except
    Result := LH_ErrGeneric;
    ReallocMem(R.Data, 0);
  end;
end;
{$ENDIF}

function LHCheck(Code: Integer): Integer;
resourcestring
  sLHSZUnspecific = 'Error in LHSZ library';
  sLHSZAlloc      = 'Error in LHSZ memory allocation';
  sLHSZInit       = 'Error in LHSZ initialization';
  sLHSZRead       = 'Readerror in LHSZ library';
  sLHSZWrite      = 'Writeerror in LHSZ library';
  sLHSZInflate    = 'Infalteerror in LHSZ library';
  sLHSZWrongCRC   = 'Checksum Error in LHSZ library';
  sLHSZPassword   = 'Wrong Password in LHSZ library';
  sLHSZProtected  = 'LHSZ data are password protected';

const
  sError: array[-9..-1] of PResStringRec =
    (@sLHSZProtected, @sLHSZPassword, @sLHSZWrongCRC, @sLHSZInflate,
     @sLHSZWrite, @sLHSZRead, @sLHSZInit, @sLHSZAlloc, @sLHSZUnspecific);

begin
  if Code < LH_Ready then
  begin
    if Code < LH_ErrProtected then Code := LH_ErrGeneric;
    raise Exception.Create(LoadResString(sError[Code]));
  end else Result := Code;
end;

end.