abdfstrm.pas

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

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Abbrevia
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1997-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* ABBREVIA: AbDfStrm.pas 3.05                           *}
{*********************************************************}
{* Deflate streams unit for various streams              *}
{*********************************************************}

unit AbDfStrm;

{$I AbDefine.inc}

interface

uses
  SysUtils,
  Classes,
  AbDfBase,
  AbDfInW,
  AbDfHufD;

type
  TAb32bit = longint; { a 32-bit type}

  PAbDfLitBuckets = ^TAbDfLitBuckets;
  TAbDfLitBuckets = array [0..285] of integer;
  PAbDfDistBuckets = ^TAbDfDistBuckets;
  TAbDfDistBuckets = array [0..31] of integer;
  PAbDfCodeLenBuckets = ^TAbDfCodeLenBuckets;
  TAbDfCodeLenBuckets = array [0..18] of integer;


const
  AbExtractMask : array [1..31] of TAb32bit =
       ($00000001, $00000003, $00000007, $0000000F,
        $0000001F, $0000003F, $0000007F, $000000FF,
        $000001FF, $000003FF, $000007FF, $00000FFF,
        $00001FFF, $00003FFF, $00007FFF, $0000FFFF,
        $0001FFFF, $0003FFFF, $0007FFFF, $000FFFFF,
        $001FFFFF, $003FFFFF, $007FFFFF, $00FFFFFF,
        $01FFFFFF, $03FFFFFF, $07FFFFFF, $0FFFFFFF,
        $1FFFFFFF, $3FFFFFFF, $7FFFFFFF);

type
  TAbDfInBitStream = class { input bit stream}
    private
      FBitBuffer : TAb32bit;
      FBitsLeft  : integer;
      FBufEnd    : PAnsiChar;
      FBuffer    : PAnsiChar;
      FBufPos    : PAnsiChar;
      FByteCount : longint;
      FFakeCount : integer;
      FOnProgress: TAbProgressStep;
      {$IFOPT C+}
      FPeekCount : integer;
      {$ENDIF}
      FStream    : TStream;
      FStreamSize: longint;
    protected
      function ibsFillBuffer : boolean;
    public
      constructor Create(aStream     : TStream;
                         aOnProgress : TAbProgressStep;
                         aStreamSize : longint);
      destructor Destroy; override;

      procedure AlignToByte;
      procedure DiscardBits(aCount : integer);
      procedure DiscardMoreBits(aCount : integer);
      function PeekBits(aCount : integer) : integer;
      function PeekMoreBits(aCount : integer) : integer;
      function ReadBit : boolean;
      function ReadBits(aCount : integer) : integer;
      procedure ReadBuffer(var aBuffer; aCount : integer);

      property BitBuffer : TAb32bit read FBitBuffer write FBitBuffer;
      property BitsLeft  : integer read FBitsLeft write FBitsLeft;
  end;

type
  TAbDfOutBitStream = class { output bit stream}
    private
      FBitBuffer : TAb32bit;
      FBitsUsed  : integer;
      FBufEnd    : PAnsiChar;
      FBuffer    : PAnsiChar;
      FBufPos    : PAnsiChar;
      FStream    : TStream;
    protected
      procedure obsEmptyBuffer;
    public
      constructor Create(aStream : TStream);
      destructor Destroy; override;

      procedure AlignToByte;
      function Position : longint;
      procedure WriteBit(aBit : boolean);
      procedure WriteBits(aBits : integer; aCount : integer);
      procedure WriteBuffer(var aBuffer; aCount : integer);
      procedure WriteMoreBits(aBits : integer; aCount : integer);

      property BitBuffer : TAb32bit read FBitBuffer write FBitBuffer;
      property BitsUsed  : integer read FBitsUsed write FBitsUsed;
  end;

type
  TAbDfLZStream = class { LZ77 token stream}
    private
      FCurPos      : PAnsiChar;
      FDistBuckets : PAbDfDistBuckets;
      FDistCount   : integer;
      FLitBuckets  : PAbDfLitBuckets;
      FLitCount    : integer;
      FLog         : TAbLogger;
      FSlideWin    : TAbDfInputWindow;
      FStartOfs    : longint;
      FStoredSize  : longint;
      FStream      : PAnsiChar;
      FStrmEnd     : PAnsiChar;
      {$IFDEF UseLogging}
      FSWPos       : longint;
      {$ENDIF}
      FUseDeflate64: boolean;
    protected
      function lzsGetApproxSize : integer;
      function lzsGetStaticSize : integer;
      function lzsGetStoredSize : integer;
      function lzsIsFull : boolean;
    public
      constructor Create(aSlideWin     : TAbDfInputWindow;
                         aUseDeflate64 : boolean;
                         aLog          : TAbLogger);
      destructor Destroy; override;

      function AddLenDist(aLen : integer; aDist : integer) : boolean;
        { returns true if the stream is "full"}
      function AddLiteral(aCh : AnsiChar) : boolean;
        { returns true if the stream is "full"}

      procedure Clear;
      procedure Encode(aBitStrm      : TAbDfOutBitStream;
                       aLitTree      : TAbDfDecodeHuffmanTree;
                       aDistTree     : TAbDfDecodeHuffmanTree;
                       aUseDeflate64 : boolean);
      procedure Rewind;

      procedure ReadStoredBuffer(var aBuffer; aCount : integer);

      property LenDistCount : integer read FDistCount;
      property LiteralCount : integer read FLitCount;

      property DistBuckets : PAbDfDistBuckets read FDistBuckets;
      property LitBuckets : PAbDfLitBuckets read FLitBuckets;

      property StaticSize  : integer read lzsGetStaticSize;{ in bits}
      property StoredSize  : integer read lzsGetStoredSize;{ in bytes}
  end;

type
  TAbDfCodeLenStream = class { codelength token stream}
    private
      FBuckets  : PAbDfCodeLenBuckets;
      FPosition : PAnsiChar;
      FStream   : PAnsiChar; {array [0..285+32*2] of byte;}
      FStrmEnd  : PAnsiChar;
    protected
    public
      constructor Create(aLog : TAbLogger);
      destructor Destroy; override;

      procedure Build(const aCodeLens : array of integer;
                            aCount    : integer);
      procedure Encode(aBitStrm : TAbDfOutBitStream;
                       aTree    : TAbDfDecodeHuffmanTree);

      property Buckets : PAbDfCodeLenBuckets read FBuckets;
  end;

implementation

uses
  AbDfCryS,
  AbDfXlat;

type
  PAb32bit = ^TAb32bit;

const
  BitStreamBufferSize = 16*1024;

{===TAbDfInBitStream=================================================}
constructor TAbDfInBitStream.Create(aStream     : TStream;
                                    aOnProgress : TAbProgressStep;
                                    aStreamSize : longint);
begin
  {protect against dumb programming mistakes}
  Assert(aStream <> nil,
         'TAbDfInBitStream.Create: Cannot create a bit stream wrapping a nil stream');

  {create the ancestor}
  inherited Create;

  {save the stream instance, allocate the buffer}
  FStream := aStream;
  GetMem(FBuffer, BitStreamBufferSize);

  {save the on progress handler}
  if Assigned(aOnProgress) and (aStreamSize > 0) then begin
    FOnProgress := aOnProgress;
    FStreamSize := aStreamSize;
  end;
end;
{--------}
destructor TAbDfInBitStream.Destroy;
begin
  {if we did some work...}
  if (FBuffer <> nil) then begin

    {reposition the underlying stream to the point where we stopped;
     this position is equal to...
      the position of the underlying stream, PLUS
      the number of fake bytes we added, LESS
      the number of bytes in the buffer, PLUS
      the position in the buffer, PLUS
      the number of complete bytes in the bit buffer}
    FStream.Seek(FStream.Position +
                 FFakeCount -
                 (FBufEnd - FBuffer) +
                 (FBufPos - FBuffer) -
                 (FBitsLeft div 8), soFromBeginning);

    {free the buffer}
    FreeMem(FBuffer);
  end;

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
procedure TAbDfInBitStream.AlignToByte;
begin
  {get rid of the odd bits by shifting them out of the bit cache}
  FBitBuffer := FBitBuffer shr (FBitsLeft mod 8);
  dec(FBitsLeft, FBitsLeft mod 8);
end;
{--------}
procedure TAbDfInBitStream.DiscardBits(aCount : integer);
var
  BitsToGo : integer;
begin
  {aCount comes from a (possibly corrupt) stream, so check that it is
   the correct range, 1..32}
  if (aCount <= 0) or (aCount > 32) then
    raise EAbInternalInflateError.Create(
       'count of bits must be between 1 and 32 inclusive [TAbDfInBitStream.DiscardBits]');

  {$IFOPT C+}
  {verify that the count of bits to discard is less than or equal to
   the recent count from PeekBits--a programming error}
  Assert((aCount <= FPeekCount),
         'TAbDfInBitStream.DiscardBits: discarding more bits than peeked');
  {since we're discarding bits already peeked, reset the peek count}
  FPeekCount := 0;
  {$ENDIF}

  {if we have more than enough bits in our bit buffer, update the
   bitbuffer and the number of bits left}
  if (aCount <= FBitsLeft) then begin
    FBitBuffer := FBitBuffer shr aCount;
    dec(FBitsLeft, aCount);
  end

  {otherwise we shall have to read another integer out of the buffer
   to satisfy the request}
  else begin
    {check that there is data in the buffer, if not it's indicates a
     corrupted stream: PeekBits should have filled it}
    if (FBufPos = FBufEnd) then
      raise EAbInternalInflateError.Create(
         'no more compressed data in stream [TAbDfInBitStream.DiscardBits]');

    {refill the bit buffer}
    BitsToGo := aCount - FBitsLeft;
    FBitBuffer := PAb32bit(FBufPos)^;
    inc(FBufPos, sizeof(TAb32bit));
    FBitBuffer := FBitBuffer shr BitsToGo;
    FBitsLeft := 32 - BitsToGo;
  end;
end;
{--------}
procedure TAbDfInBitStream.DiscardMoreBits(aCount : integer);
var
  BitsToGo : integer;
begin
  {aCount comes from a (possibly corrupt) stream, so check that it is
   the correct range, 1..32}
  if (aCount <= 0) or (aCount > 32) then
    raise EAbInternalInflateError.Create(
       'count of bits must be between 1 and 32 inclusive [TAbDfInBitStream.DiscardMoreBits]');

  {$IFOPT C+}
  {verify that the count of bits to discard is less than or equal to
   the recent count from PeekBits--a programming error}
  Assert((aCount <= FPeekCount),
         'TAbDfInBitStream.DiscardBits: discarding more bits than peeked');
  {since we're discarding bits already peeked, reset the peek count}
  FPeekCount := 0;
  {$ENDIF}

  {check that there is data in the buffer, if not it's indicates a
   corrupted stream: PeekBits/PeekMoreBits should have filled it}
  if (FBufPos = FBufEnd) then
    raise EAbInternalInflateError.Create(
       'no more compressed data in stream [TAbDfInBitStream.DiscardBits]');

  {refill the bit buffer}
  BitsToGo := aCount - FBitsLeft;
  FBitBuffer := PAb32bit(FBufPos)^;
  inc(FBufPos, sizeof(TAb32bit));
  FBitBuffer := FBitBuffer shr BitsToGo;
  FBitsLeft := 32 - BitsToGo;
end;
{--------}
function TAbDfInBitStream.ibsFillBuffer : boolean;
var
  BytesRead   : longint;
  BytesToRead : longint;
  i           : integer;
  Percent     : integer;
  Buffer      : PAnsiChar;
  BufferCount : integer;
begin
  {check for dumb programming mistakes: this routine should only be
   called if there are less than 4 bytes unused in the buffer}
  Assert((FBufEnd - FBufPos) < sizeof(longint),
         'TAbDfInBitStream.ibsFillBuffer: the buffer should be almost empty');

  {if there are still 1, 2, or three bytes unused, move them to the
   front of the buffer}
  Buffer := FBuffer;
  while (FBufPos <> FBufEnd) do begin
    Buffer^ := FBufPos^;
    inc(FBufPos);
    inc(Buffer);
  end;

  {fill the buffer}
  BytesToRead := BitStreamBufferSize - (Buffer - FBuffer);
  BytesRead := FStream.Read(Buffer^, BytesToRead);

  {reset the internal pointers}
  FBufPos := FBuffer;
  FBufEnd := Buffer + BytesRead;
  BufferCount := FBufEnd - FBuffer;

  {if, as a result of the read, no data is in the buffer, return
   false; the caller will decide what to do about the problem}