abunzprc.pas

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

{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzFlushOutBuf;
  {-flushes the output buffer}
var
  tempCRC : LongInt;
  Abort : Boolean;
  NewProgress : byte;
begin
  if (FOutPos <> 0) then begin
    FOutWriter.Write( FOutBuf^, FOutPos );
    inc( FOutSent, FOutPos );

    tempCRC := FCRC32;
    AbUpdateCRC( tempCRC, FOutBuf^, FOutPos );
    FOutPos := 0;
    FCRC32 := tempCRC;
  end;
  Abort := False;
  NewProgress := AbPercentage(FOutSent, FUncompressedSize);
  if (NewProgress <> FCurrentProgress) then
    DoProgress(NewProgress, Abort);
  if Abort then
    raise EAbUserAbort.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzWriteByte(B : Byte);
  {-Write one byte to the output buffer}
begin
  FOutBuf^[FOutPos] := B;
  inc(FOutPos);
  if (FOutPos = AbBufferSize) or
     (LongInt(FOutPos) + FOutSent = FUncompressedSize) then
    uzFlushOutBuf;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.DoRequestNthDisk( DiskNumber : Byte;
                                           var Abort : Boolean );
var
  pMessage : string;
  pCaption : string;
begin
  if Assigned( FOnRequestNthDisk ) then
    FOnRequestNthDisk( Self, DiskNumber, Abort )
  else begin
    pMessage:= Format(AbStrRes(AbDiskNumRequest), [DiskNumber]);
    pCaption := AbStrRes(AbDiskRequest);
    {$IFDEF MSWINDOWS}
    Abort := Windows.MessageBox( 0, PChar(pMessage), PChar(pCaption),
      MB_TASKMODAL or MB_OKCANCEL ) = IDCANCEL;
    {$ENDIF}
    {$IFDEF LINUX}
    {$IFDEF NoQt}
    WriteLn(pMessage);
    {$ELSE }
    Abort := QDialogs.MessageDlg(pCaption, pMessage, mtWarning, mbOKCancel, 0) = mrCancel;
    {$ENDIF}
    {$ENDIF}
  end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.DoProgress(Progress : Byte; var Abort : Boolean);
begin
  if (not Assigned(FOnProgress)) or (Progress = FCurrentProgress) then
    Exit
  else
    FCurrentProgress := Progress;
  FOnProgress(Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipHelper.uzReadBits(Bits : Byte) : Integer;
  {-Read the specified number of bits}
var
  SaveCurByte, Delta, SaveBitsLeft : Byte;
begin
  {read next byte if we're out of bits}
  if FBitsLeft = 0 then begin
    {uzReadNext;}
    {do we still have a byte buffered?}
    if FInPos <= FInCnt then begin
      {get next byte out of buffer and advance position counter}
      FCurByte := FInBuf[FInPos];
      Inc(FInPos);
    end
    {are there any left to read?}
    else
      uzReadNextPrim;

    FBitsLeft := 8;
  end;
  if ( Bits < FBitsLeft ) then begin
    Dec( FBitsLeft, Bits );
    Result := ((1 shl Bits) - 1) and FCurByte;
    FCurByte := FCurByte shr Bits;
  end
  else if ( Bits = FBitsLeft ) then begin
    Result := FCurByte;
    FCurByte := 0;
    FBitsLeft := 0;
  end
  else begin
    SaveCurByte := FCurByte;
    SaveBitsLeft := FBitsLeft;
    {number of additional bits that we need}
    Delta := Bits - FBitsLeft;
    {read next byte}
    {uzReadNext;}
    {do we still have a byte buffered?}
    if FInPos <= FInCnt then begin
      {get next byte out of buffer and advance position counter}
      FCurByte := FInBuf[FInPos];
      Inc(FInPos);
    end
    {are there any left to read?}
    else
      uzReadNextPrim;

    FBitsLeft := 8;
    Result := ( uzReadBits( Delta ) shl SaveBitsLeft ) or SaveCurByte;
  end;
end;
{$IFDEF UnzipImplodeSupport}
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzUnImplode;
    {-Extract an imploded file}
const
  szLengthTree = SizeOf(TAbSfTree)-(192*SizeOf(TAbSfEntry));
  szDistanceTree = SizeOf(TAbSfTree)-(192*SizeOf(TAbSfEntry));
  szLitTree = SizeOf(TAbSfTree);
var
  Length : Integer;
  DIndex : LongInt;
  Distance : Integer;
  SPos : LongInt;
  MyByte : Byte;
  DictBits : Integer;             {number of bits used in sliding dictionary}
  MinMatchLength : Integer;       {minimum match length}
  LitTree : PAbSfTree;              {Literal tree}
  LengthTree : PAbSfTree;           {Length tree}
  DistanceTree : PAbSfTree;         {Distance tree}

  procedure uzLoadTree(var T; TreeSize : Integer);
    {-Load one Shannon-Fano tree}
  var
    I : Word;
    Tree : TAbSfTree absolute T;

    procedure GenerateTree;
      {-Generate a Shannon-Fano tree}
    var
      C : Word;
      CodeIncrement : Integer;
      LastBitLength : Integer;
      I : Integer;
    begin
      C := 0;
      CodeIncrement := 0;
      LastBitLength := 0;

      for I := Tree.Entries-1 downto 0 do
        with Tree.Entry[I] do begin
          Inc(C, CodeIncrement);
          if BitLength <> LastBitLength then begin
            LastBitLength := BitLength;
            CodeIncrement := 1 shl (16-LastBitLength);
          end;
          Code := C;
        end;
    end;

    procedure SortLengths;
      {-Sort the bit lengths in ascending order, while retaining the order
        of the original lengths stored in the file}
    var
      XL : Integer;
      XGL : Integer;
      TXP  : PAbSfEntry;
      TXGP : PAbSfEntry;
      X, Gap : Integer;
      Done : Boolean;
      LT : LongInt;
    begin
      Gap := Tree.Entries shr 1;
      repeat
        repeat
          Done := True;
          for X := 0 to (Tree.Entries-1)-Gap do begin
            TXP := @Tree.Entry[X];
            TXGP := @Tree.Entry[X+Gap];
            XL := TXP^.BitLength;
            XGL := TXGP^.BitLength;
            if (XL > XGL) or
               ((XL = XGL) and (TXP^.Value > TXGP^.Value)) then begin
              LT := TXP^.L;
              TXP^.L := TXGP^.L;
              TXGP^.L := LT;
              Done := False;
            end;
          end;
        until Done;

        Gap := Gap shr 1;
      until (Gap = 0);
    end;

    procedure uzReadLengths;
      {-Read bit lengths for a tree}
    var
      TreeBytes : Integer;
      I, J, K : Integer;
      Num, Len : Integer;
      B : Byte;
    begin
      {get number of bytes in compressed tree}
      TreeBytes := uzReadBits(8)+1;

      I := 0;
      Tree.MaxLength := 0;

      {High nibble: Number of values at this bit length + 1.
       Low  nibble: Bits needed to represent value + 1}
      for J := 1 to TreeBytes do begin
        B := uzReadBits(8);
        Len := (B and $0F)+1;
        Num := (B shr 4)+1;

        for K := I to I+Num-1 do
          with Tree, Entry[K] do begin
            if Len > MaxLength then
              MaxLength := Len;
            BitLength := Len;
            Value := K;
          end;
        Inc(I, Num);
      end;
    end;

  begin
    Tree.Entries := TreeSize;
    uzReadLengths;
    SortLengths;
    GenerateTree;
    for I := 0 to TreeSize-1 do
      AbReverseBits(Tree.Entry[I].Code);
  end;

  function uzReadTree(var T) : Byte;
    {-Read next byte using a Shannon-Fano tree}
  const
    Bits : Integer = 0;
    CV   : Word = 0;
    E    : Integer = 0;
    Cur  : Integer = 0;
  var
    Tree : TAbSfTree absolute T;
  begin
    Result := 0;
    Bits := 0;
    CV := 0;
    Cur := 0;
    E := Tree.Entries;
    repeat
      CV := CV or (uzReadBits(1) shl Bits);
      Inc(Bits);
      while Tree.Entry[Cur].BitLength < Bits do begin
        Inc(Cur);
        if Cur >= E then
          Exit;
      end;
      while Tree.Entry[Cur].BitLength = Bits do begin
        if Tree.Entry[Cur].Code = CV then begin
          Result := Tree.Entry[Cur].Value;
          Exit;
        end;
        Inc(Cur);
        if Cur >= E then
          Exit;
      end;
    until False;
  end;

begin
  {do we have an 8K dictionary?}
  if FDictionarySize = ds8K then
    DictBits := 7
  else
    DictBits := 6;

  {allocate trees}
  LengthTree := AllocMem(szLengthTree);
  DistanceTree := AllocMem(szDistanceTree);
  LitTree := nil;
  try
    {do we have a Literal tree?}
    MinMatchLength := FShannonFanoTreeCount;
    if MinMatchLength = 3 then begin
      LitTree := AllocMem(szLitTree);
      uzLoadTree(LitTree^, 256);
    end;

    {load the other two trees}
    uzLoadTree(LengthTree^, 64);
    uzLoadTree(DistanceTree^, 64);

    while (not FInEof) and (FOutSent + LongInt(FOutPos) < FUncompressedSize) do 
      {is data literal?}
      if Boolean(uzReadBits(1)) then begin
        {if MinMatchLength = 3 then we have a Literal tree}
        if (MinMatchLength = 3) then
          uzWriteByte( uzReadTree(LitTree^) )
        else
          uzWriteByte( uzReadBits(8) );
      end
      else begin
        {data is a sliding dictionary}
        Distance := uzReadBits(DictBits);

        {using the Distance Shannon-Fano tree, read and decode the
         upper 6 bits of the Distance value}
        Distance := Distance or (uzReadTree(DistanceTree^) shl DictBits);

        {using the Length Shannon-Fano tree, read and decode the Length value}
        Length := uzReadTree(LengthTree^);
        if Length = 63 then
          Inc(Length, uzReadBits(8));
        Inc(Length, MinMatchLength);

        {move backwards Distance+1 bytes in the output stream, and copy
         Length characters from this position to the output stream.
         (if this position is before the start of the output stream,
         then assume that all the data before the start of the output
         stream is filled with zeros)}
        DIndex := (FOutSent + LongInt(FOutPos))-(Distance+1);
        while Length > 0 do begin
          if DIndex < 0 then
            uzWriteByte(0)
          else begin
            uzFlushOutBuf;
            SPos := FOutWriter.Position;
            FOutWriter.Position := DIndex;
            FOutWriter.Read( MyByte, 1 );
            FOutWriter.Position := SPos;
            uzWriteByte(MyByte);
          end;
          Inc(DIndex);
          Dec(Length);
        end;
      end;
  finally
    if (LitTree <> nil) then
      FreeMem(LitTree, szLitTree);
    FreeMem(LengthTree, szLengthTree);
    FreeMem(DistanceTree, szDistanceTree);
  end;
end;
{$ENDIF UnzipImplodeSupport}
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipReduceSupport}
procedure TAbUnzipHelper.uzUnReduce;
const
  FactorMasks : array[1..4] of Byte = ($7F, $3F, $1F, $0F);
  DLE = 144;
var
  C, Last : Byte;
  OpI : LongInt;
  OpO : LongInt;
  I, J, Sz : Integer;
  D : Word;
  SPos : LongInt;
  MyByte : Byte;
  Factor : Byte;                  {reduction Factor}
  FactorMask : Byte;              {bit mask to use based on Factor}
  Followers : PAbFollowerSets;      {array of follower sets}
  State : Integer;                {used while processing reduced files}
  V : Integer;                    {"}
  Len : Integer;                  {"}

  function BitsNeeded( i : Byte ) : Word;
  begin