abunzprc.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

    dec( i );
    Result := 0;
    repeat
      inc( Result );
      i := i shr 1;
    until i = 0;
  end;

begin
  GetMem(Followers, SizeOf(Followers^));
  try
    Factor := Ord( FCompressionMethod ) - 1;
    FactorMask := FactorMasks[Factor];
    State := 0;
    C := 0;
    V := 0;
    Len := 0;
    D := 0;

    {load follower sets}
    for I := 255 downto 0 do begin
      Sz := uzReadBits(6);
      Followers^[I].Size := Sz;
      Dec(Sz);
      for J := 0 to Sz do
        Followers^[I].FSet[J] := uzReadBits(8);
    end;

    while (not FInEof) and ((FOutSent + LongInt(FOutPos)) < FUncompressedSize) do begin 
      Last := C;
      with Followers^[Last] do
        if Size = 0 then
          C := uzReadBits(8)
        else begin
          C := uzReadBits(1);
          if C <> 0 then
            C := uzReadBits(8)
          else
            C := FSet[uzReadBits(BitsNeeded(Size))];
        end;

      if FInEof then
        Exit;

      case State of
        0 :
          if C <> DLE then
            uzWriteByte(C)
          else
            State := 1;
        1 :
          if C <> 0 then begin
            V := C;
            Len := V and FactorMask;
            if Len = FactorMask then
              State := 2
            else
              State := 3;
          end
          else begin
            uzWriteByte(DLE);
            State := 0;
          end;

        2 :
          begin
            Inc(Len, C);
            State := 3;
          end;

        3 :
          begin
            case Factor of
              1 : D := (V shr 7) and $01;
              2 : D := (V shr 6) and $03;
              3 : D := (V shr 5) and $07;
              4 : D := (V shr 4) and $0f;
            else
              raise EAbZipInvalidFactor.Create;
            end;
            {Delphi raises compiler Hints here, saying D might
             be undefined...  If Factor is not in [1..4], the
             exception gets raised, and we never execute the following
             line}
            OpI := (FOutSent + LongInt(FOutPos))-(Swap(D)+C+1);

            if OpI >= 8192 then
              OpO := OpI mod 8192
            else
              OpO := OpI;
            for I := 0 to Len+2 do begin
              if OpI < 0 then
                uzWriteByte(0)
              else begin
                SPos := FOutWriter.Position;
                FOutWriter.Position := OpO;
                FOutWriter.Read( MyByte, 1 );
                FOutWriter.Position := SPos;
                uzWriteByte(MyByte);
              end;
              Inc(OpI);
              Inc(OpO);
              if OpO >= 8192 then
                OpO := 0;
            end;

            State := 0;
          end;
      end;
    end;
  finally
    FreeMem(Followers, SizeOf(Followers^));
  end;
end;
{$ENDIF UnzipReduceSupport}
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipShrinkSupport}
procedure TAbUnzipHelper.uzUnShrink;
  {-Extract a file that was shrunk}
const
  MaxBits = 13;
  InitBits = 9;
  FirstFree = 257;
  Clear = 256;
  MaxCodeMax = 8192; {= 1 shl MaxBits}
  Unused = -1;
var
  CodeSize : SmallInt;
  NextFree : SmallInt;
  BaseChar : SmallInt;
  NewCode : SmallInt;
  OldCode : SmallInt;
  SaveCode : SmallInt;
  N, R : SmallInt;
  I : Integer;
  PrefixTable : PAbIntArray8K;      {used while processing shrunk files}
  SuffixTable : PAbByteArray8K;     {"}
  Stack : PAbByteArray8K;           {"}
  StackIndex : Integer;           {"}
begin
  CodeSize := InitBits;
{  MaxCode := (1 shl InitBits)-1;}
  NextFree := FirstFree;

  PrefixTable := nil;
  SuffixTable := nil;
  Stack := nil;

  try
    GetMem(PrefixTable, SizeOf(PrefixTable^));
    SuffixTable := AllocMem(SizeOf(SuffixTable^));
    GetMem(Stack, SizeOf(Stack^));

    FillChar(PrefixTable^, SizeOf(PrefixTable^), $FF);
    for NewCode := 255 downto 0 do begin
      PrefixTable^[NewCode] := 0;
      SuffixTable^[NewCode] := NewCode;
    end;

    OldCode := uzReadBits(CodeSize);
    if FInEof then
      Exit;
    BaseChar := OldCode;

    uzWriteByte(BaseChar);

    StackIndex := 0;
    while (not FInEof) do begin
      NewCode := uzReadBits(CodeSize);
      while (NewCode = Clear) and (not FInEof) do begin
        case uzReadBits(CodeSize) of
          1 : begin
                Inc(CodeSize);
              end;
          2 : begin
                {mark all nodes as potentially unused}
                for I := FirstFree to pred( NextFree ) do
                  PrefixTable^[I] := PrefixTable^[I] or LongInt($8000);

                {unmark those used by other nodes}
                for N := FirstFree to NextFree-1 do begin
                  {reference to another node?}
                  R := PrefixTable^[N] and $7FFF;
                  {flag node as referenced}
                  if R >= FirstFree then
                    PrefixTable^[R] := PrefixTable^[R] and $7FFF;
                end;

                {clear the ones that are still marked}
                for I := FirstFree to pred( NextFree ) do
                  if PrefixTable^[I] < 0 then
                    PrefixTable^[I] := -1;

                {recalculate NextFree}
                NextFree := FirstFree;
                while (NextFree < MaxCodeMax) and
                      (PrefixTable^[NextFree] <> -1) do
                  Inc(NextFree);
              end;
        end;

        NewCode := uzReadBits(CodeSize);
      end;

      if FInEof then
        Exit;

      {save current code}
      SaveCode := NewCode;

      {special case}
      if PrefixTable^[NewCode] = Unused then begin
        Stack^[StackIndex] := BaseChar;
        Inc(StackIndex);
        NewCode := OldCode;
      end;

      {generate output characters in reverse order}
      while (NewCode >= FirstFree) do begin
        if PrefixTable^[NewCode] = Unused then begin
          Stack^[StackIndex] := BaseChar;
          Inc(StackIndex);
          NewCode := OldCode;
        end else begin
          Stack^[StackIndex] := SuffixTable^[NewCode];
          Inc(StackIndex);
          NewCode := PrefixTable^[NewCode];
        end;
      end;

      BaseChar := SuffixTable^[NewCode];
      uzWriteByte(BaseChar);

      {put them out in forward order}
      while (StackIndex > 0) do begin
        Dec(StackIndex);
        uzWriteByte(Stack^[StackIndex]);
      end;

      {add new entry to tables}
      NewCode := NextFree;
      if NewCode < MaxCodeMax then begin
        PrefixTable^[NewCode] := OldCode;
        SuffixTable^[NewCode] := BaseChar;
        while (NextFree < MaxCodeMax) and
              (PrefixTable^[NextFree] <> Unused) do
          Inc(NextFree);
      end;

      {remember previous code}
      OldCode := SaveCode;
    end;
  finally
    FreeMem(PrefixTable, SizeOf(PrefixTable^));
    FreeMem(SuffixTable, SizeOf(SuffixTable^));
    FreeMem(Stack, SizeOf(Stack^));
  end;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure RequestPassword(Archive : TAbZipArchive; var Abort : Boolean);
var
  APassPhrase : string;
begin
  Abort := False;
  if Assigned(Archive.OnNeedPassword) then begin
    Archive.OnNeedPassword(Archive, APassPhrase);
    if APassPhrase = '' then
      Abort := True
    else
      Archive.Password := APassPhrase;
  end;
end;
{ -------------------------------------------------------------------------- }
procedure CheckPassword(Archive : TAbZipArchive; var Tries : Integer; var Abort : Boolean);
begin
  { if current password empty }
  if Archive.Password = '' then begin
    { request password }
    RequestPassword(Archive, Abort);
    { increment tries }
    Inc(Tries);
  end;

  { if current password still empty }
  if Archive.Password = '' then begin
    { abort }
    raise EAbZipInvalidPassword.Create;
  end;
end;


{ -------------------------------------------------------------------------- }
function DoInflate(Archive : TAbZipArchive; Item : TAbZipItem; OutStream : TStream; TheCRC : LongInt) : LongInt;
var
  Hlpr  : TAbDeflateHelper;
  Tries : Integer;
  Successful : Boolean;
  Abort : Boolean;
begin
  Hlpr := TAbDeflateHelper.Create;

  if (OutStream is TAbBitBucketStream) then  { we're just validating the item }
    Hlpr.Options := Hlpr.Options or dfc_TestOnly;

  if Item.CompressionMethod = cmEnhancedDeflated then
    Hlpr.Options := Hlpr.Options or dfc_UseDeflate64;

  Hlpr.StreamSize := Item.CompressedSize;                                {!!.02}
  Hlpr.OnProgressStep := Archive.DoInflateProgress;

  Result := 0;

  try
    if not (Item.IsEncrypted) then begin
      { just inflate it }
      Result := Inflate(Archive.FStream, OutStream, Hlpr);
    end
    else begin { it's encrypted }
      Tries := 0;
      Successful := False;
      Abort := False;
      CheckPassword(Archive, Tries, Abort);
      if Abort then
        raise EAbUserAbort.Create;


      Hlpr.Passphrase := Archive.Password;
      Hlpr.CheckValue := TheCRC;
      repeat
        try
          { attempt to inflate }
          Result := Inflate(Archive.FStream, OutStream, Hlpr);
          Successful := True;
        except
          on E:EAbInflatePasswordError do begin { bad password? }
            { request password }
            RequestPassword(Archive, Abort);
            if Abort then
              raise EAbUserAbort.Create;
            { increment tries }
            Inc(Tries);
          end;
        end;
        if (Tries > Archive.PasswordRetries) then begin
          raise EAbZipInvalidPassword.Create;
        end;
      until Successful or Abort or (Tries >= Archive.PasswordRetries);

    end; { if encrypted }

  finally
    Hlpr.Free;
  end;
end;
{ -------------------------------------------------------------------------- }
function DoExtractStored(Archive : TAbZipArchive; Item : TAbZipItem; OutStream : TStream; TheCRC : LongInt) : LongInt;
var
  DataRead    : LongInt;
  CRC32       : LongInt;
  Percent     : LongInt;
  LastPercent : LongInt;

  Tries : Integer;
  Total       : LongInt;
  Remaining   : LongInt;
  SizeToRead  : LongInt;
  Abort       : Boolean;
  Buffer      : array [0..1023] of byte;
  DecryptStream : TAbDfDecryptStream;
begin
  { setup }
  Total   := 0;
  Remaining := Item.UncompressedSize;
  Abort   := False;
  CRC32   := -1;
  Percent := 0;
  LastPercent := 0;