abdfbase.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: AbDfBase.pas 3.05                           *}
{*********************************************************}
{* Deflate base unit                                     *}
{*********************************************************}

unit AbDfBase;

{$I AbDefine.inc}

interface

uses
  SysUtils,
  Classes;

type
  PAbDfLongintList = ^TAbDfLongintList;
  TAbDfLongintList =
               array [0..pred(MaxInt div sizeof(longint))] of longint;

const
  dfc_CodeLenCodeLength = 7;
  dfc_LitDistCodeLength = 15;
  dfc_MaxCodeLength     = 15;

const
  dfc_MaxMatchLen = 258;         {lengths are 3..258 for deflate}
  dfc_MaxMatchLen64 = 64 * 1024; {lengths are 3..65536  for deflate64}

const
  dfc_LitExtraOffset = 257;
  dfc_LitExtraBits : array [0..30] of byte =
    (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3,
     4, 4, 4, 4, 5, 5, 5, 5, 16, 99, 99);
     { note: the last two are required to avoid going beyond the end}
     {       of the array when generating static trees}

  dfc_DistExtraOffset = 0;
  dfc_DistExtraBits : array [0..31] of byte =
    (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9,
     10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
     { note: the last two are only use for deflate64}

  dfc_LengthBase : array [0..28] of word =
    (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43,
     51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 3);
     { note: the final 3 is correct for deflate64; for symbol 285,}
     {       lengths are stored as (length - 3)}
     {       for deflate it's very wrong, but there's special code in}
     {       the (de)compression code to cater for this}

  dfc_DistanceBase : array [0..31] of word =
    (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257,
     385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289,
     16385, 24577, 32769, 49153);

  dfc_CodeLengthIndex : array [0..18] of byte =
    (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);

const
  dfc_CanUseStored  = $01;
  dfc_CanUseStatic  = $02;
  dfc_CanUseDynamic = $04;
  dfc_UseLazyMatch  = $08;
  dfc_UseDeflate64  = $10;
  dfc_UseAdler32    = $20;
  dfc_CanUseHuffman = dfc_CanUseStatic or dfc_CanUseDynamic;
  dfc_TestOnly      = $40000000;

type
  TAbProgressStep = procedure (aPercentDone : integer) of object;
    {-progress metering of deflate/inflate; abort with AbortProgress}

  TAbDeflateHelper = class
    private
      FAmpleLength    : longint;
      FChainLength    : longint;
      FCheckValue     : longint;
      FLogFile        : string;
      FMaxLazy        : longint;
      FOnProgressStep : TAbProgressStep;
      FOptions        : longint;
      FPartSize       : longint;
      FPassphrase     : string;
      FSizeCompressed : longint;
      FSizeNormal     : longint;
      FStreamSize     : longint;
      FWindowSize     : longint;
      FZipOption      : AnsiChar;
    protected
      procedure dhSetAmpleLength(aValue : longint);
      procedure dhSetChainLength(aValue : longint);
      procedure dhSetCheckValue(aValue : longint);
      procedure dhSetLogFile(aValue : string);
      procedure dhSetMaxLazy(aValue : longint);
      procedure dhSetOnProgressStep(aValue : TAbProgressStep);
      procedure dhSetOptions(aValue : longint);
      procedure dhSetPassphrase(aValue : string);
      procedure dhSetWindowSize(aValue : longint);
      procedure dhSetZipOption(aValue : AnsiChar);
    public
      constructor Create;

      procedure Assign(aHelper : TAbDeflateHelper);

      property AmpleLength : longint
                  read FAmpleLength write dhSetAmpleLength;
      property ChainLength : longint
                  read FChainLength write dhSetChainLength;
      property CheckValue : longint
                  read FCheckValue write dhSetCheckValue;
      property LogFile : string
                  read FLogFile write dhSetLogFile;
      property MaxLazyLength : longint
                  read FMaxLazy write dhSetMaxLazy;
      property Options : longint
                  read FOptions write dhSetOptions;
      property PartialSize : longint
                  read FPartSize write FPartSize;
      property Passphrase : string
                  read FPassphrase write dhSetPassphrase;
      property PKZipOption : AnsiChar
                  read FZipOption write dhSetZipOption;
      property StreamSize : longint
                  read FStreamSize write FStreamSize;
      property WindowSize : longint
                  read FWindowSize write dhSetWindowSize;

      property CompressedSize : longint
                  read FSizeCompressed write FSizeCompressed;
      property NormalSize : longint
                  read FSizeNormal write FSizeNormal;

      property OnProgressStep : TAbProgressStep
                  read FOnProgressStep write dhSetOnProgressStep;
  end;

type
  TAbLineDelimiter = (ldCRLF, ldLF);

  TAbLogger = class(TStream)
    private
      FBuffer    : PAnsiChar;
      FCurPos    : PAnsiChar;
      FLineDelim : TAbLineDelimiter;
      FStream    : TFileStream;
    protected
      function logWriteBuffer : boolean;
    public
      constructor Create(const aLogName : string);
      destructor Destroy; override;

      function Read(var Buffer; Count : longint) : longint; override;
      function Seek(Offset : longint; Origin : word) : longint; override;
      function Write(const Buffer; Count : longint) : longint; override;
      procedure WriteLine(const S : string);
      procedure WriteStr(const S : string);

      property LineDelimiter : TAbLineDelimiter
                  read FLineDelim write FLineDelim;
  end;

type
  TAbNodeManager = class
    private
      FFreeList     : pointer;
      FNodeSize     : cardinal;
      FNodesPerPage : cardinal;
      FPageHead     : pointer;
      FPageSize     : cardinal;
    protected
      function nmAllocNewPage : pointer;
    public
      constructor Create(aNodeSize : cardinal);
      destructor Destroy; override;

      function AllocNode : pointer;
      function AllocNodeClear : pointer;
      procedure FreeNode(aNode : pointer);
  end;

{---exception classes---}
type
  EAbAbortProgress = class(Exception);
  EAbPartSizedInflate = class(Exception);
  EAbInflatePasswordError = class(Exception);
  EAbInternalInflateError = class(Exception);
  EAbInflateError = class(Exception)
    public
      constructor Create(const aMsg : string);
      constructor CreateUnknown(const aMsg : string;
                                const aErrorMsg : string);
  end;
  EAbInternalDeflateError = class(Exception);
  EAbDeflateError = class(Exception)
    public
      constructor Create(const aMsg : string);
      constructor CreateUnknown(const aMsg : string;
                                const aErrorMsg : string);
  end;

{---aborting a process---}
procedure AbortProgress;

{---calculation of checksums---}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
                              var aBuffer; aCount : integer);
procedure AbUpdateCRCBuffer(var aCRC : longint;
                            var aBuffer; aCount : integer);


implementation

uses
  AbUtils;

type
  {$IFDEF HasLongWord}
  DblWord = longword;
  {$ELSE}
  DblWord = longint;
  {$ENDIF}

{===TAbDeflateHelper=================================================}
constructor TAbDeflateHelper.Create;
begin
  inherited Create;
  FAmpleLength := 8;
  FChainLength := 32;
  FCheckValue := -1;
  {FLogFile := '';}
  FMaxLazy := 16;
  {FOnProgressStep := nil;}
  FOptions := $F;
  {FPassphrase := '';}
  {FStreamSize := 0;}
  FWindowSize := 32 * 1024;
  FZipOption := 'n';
end;
{--------}
procedure TAbDeflateHelper.Assign(aHelper : TAbDeflateHelper);
begin
  FAmpleLength := aHelper.FAmpleLength;
  FChainLength := aHelper.FChainLength;
  FCheckValue := aHelper.FCheckValue;
  FLogFile := aHelper.FLogFile;
  FMaxLazy := aHelper.FMaxLazy;
  FOnProgressStep := aHelper.FOnProgressStep;
  FOptions := aHelper.FOptions;
  FPartSize := aHelper.FPartSize;
  FPassphrase := aHelper.FPassphrase;
  FStreamSize := aHelper.FStreamSize;
  FWindowSize := aHelper.FWindowSize;
  FZipOption := aHelper.FZipOption;
end;
{--------}
procedure TAbDeflateHelper.dhSetAmpleLength(aValue : longint);
begin
  if (aValue <> AmpleLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FAmpleLength := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetChainLength(aValue : longint);
begin
  if (aValue <> ChainLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FChainLength := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetCheckValue(aValue : longint);
begin
  {Note: the CheckValue is only required during the inflate of an
         encrypted stream. The encryption header contains part of the
         CheckValue encrypted and this is used to check that the
         supplied passphrase was correct.
         The CheckValue is usually the CRC of the uncompressed stream
         and the zip file has this value readily to hand prior to
         decompression. With encryption during deflate the code will
         calculate the CheckValue of the uncompressed stream prior to
         compressing it.}
  FCheckValue := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetLogFile(aValue : string);
begin
  FLogFile := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetMaxLazy(aValue : longint);
begin
  if (aValue <> MaxLazyLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FMaxLazy := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetOnProgressStep(aValue : TAbProgressStep);
begin
  FOnProgressStep := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetOptions(aValue : longint);
begin
  if (aValue <> Options) then begin
    FOptions := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetPassphrase(aValue : string);
begin
  FPassphrase := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetWindowSize(aValue : longint);
var
  NewValue : longint;
begin
  if (aValue <> WindowSize) then begin
    {calculate the window size rounded to nearest 1024 bytes}
    NewValue := ((aValue + 1023) div 1024) * 1024;
    {if the new window size is greater than 32KB...}
    if (NewValue > 32 * 1024) then
      {if the Deflate64 option is set, force to 64KB}
      if ((Options and dfc_UseDeflate64) <> 0) then
        NewValue := 64 * 1024
      {otherwise, force to 32KB}
      else
        NewValue := 32 * 1024;
    {set the new window size}
    FWindowSize := NewValue;
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetZipOption(aValue : AnsiChar);
begin
  {notes:
     The original Abbrevia code used the following table for
     setting the equivalent values:
            Good  Lazy  Chain  UseLazy  Option
               4     4      4     N       s        ^
               4     5      8     N                |
               4     6     32     N       f      faster
               4     4     16     Y              slower
               8    16     32     Y       n        |
               8    16    128     Y                |
               8    32    256     Y                |
              32   128   1024     Y                |
              32   258   4096     Y       x        V
     The new Abbrevia 3 code follows these values to a certain extent.
  }

  {force to lower case}
  if ('A' <= aValue) and (aValue <= 'Z') then
    aValue := AnsiChar(ord(aValue) + ord('a') - ord('A'));

  {if the value has changed...}
  if (aValue <> PKZipOption) then begin

    {switch on the new value...}
    case aValue of
      '0' : {no compression}
        begin
          FZipOption := aValue;
          FOptions := (FOptions and (not $0F)) or dfc_CanUseStored;
          FAmpleLength := 8;  { not actually needed}
          FChainLength := 32; { not actually needed}
          FMaxLazy := 16;     { not actually needed}
        end;
      '2' : {hidden option: Abbrevia 2 compatibility}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 8;
          FChainLength := 32;
          FMaxLazy := 16;
        end;
      'f' : {fast compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $07; { no lazy matching}
          FAmpleLength := 4;
          FChainLength := 32;
          FMaxLazy := 6;
        end;
      'n' : {normal compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 16;
          FChainLength := 32;
          FMaxLazy := 24;
        end;
      's' : {super fast compression}