xtool/contrib/mORMot/SynBz.pas

/// fast BZ2 compression/decompression
// - licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynBz;

{
    This file is part of Synopse BZ2 Compression.

    Synopse Synopse BZ2 Compression. Copyright (C) 2022 Arnaud Bouchez
      Synopse Informatique - https://synopse.info

  *** BEGIN LICENSE BLOCK *****
  Version: MPL 1.1/GPL 2.0/LGPL 2.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 Synopse BZ2 Compression.

  The Initial Developer of the Original Code is Arnaud Bouchez.

  Portions created by the Initial Developer are Copyright (C) 2022
  the Initial Developer. All Rights Reserved.

  Contributor(s):
  Alternatively, the contents of this file may be used under the terms of
  either the GNU General Public License Version 2 or later (the "GPL"), or
  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  in which case the provisions of the GPL or the LGPL are applicable instead
  of those above. If you wish to allow use of your version of this file only
  under the terms of either the GPL or the LGPL, and not to allow others to
  use your version of this file under the terms of the MPL, indicate your
  decision by deleting the provisions above and replace them with the notice
  and other provisions required by the GPL or the LGPL. If you do not delete
  the provisions above, a recipient may use your version of this file under
  the terms of any one of the MPL, the GPL or the LGPL.

  ***** END LICENSE BLOCK *****


  Cross-platform BZLib implementation
  ===================================

   decompression:
      - can use inline assembler version (bunzipasm.inc)
      - more than 2 times faster than standard C version
      - no external .obj necessary
      - 100% API compatible
      - does CRC Bz2Check
      - fully tested under Delphi, should work with (Cross)Kylix
    asm translation extracted from isbunzip.dll and optimized for Delphi 7

    compression:
      - use fast bzip.dll (faster than standard C version)

    Cross-Platform:
      - under Win32, use fast bzip.dll (provided in bzasm.zip) + assembler
      - under Linux, use default libbz2.so
       (Linux can use faster assembler version - must be checked if this
        is really useful)

  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 Initial Developer of the Original Code is Arnaud Bouchez.
  This work is Copyright (C) 2008 Arnaud Bouchez - http://bouchez.info

  All Rights Reserved.


  Version 1.18
  - fixed ticket [2783e5f81b] about UNICODE compilation issue


}


interface

{$define USEBZAASM}
// use ASM version of bunzip.dll (ok as far as tested)

uses
  SysUtils, Types, Classes,
{$ifdef MSWINDOWS}
  Windows;
{$else}
  LibC;
{$endif}

type
  TBZAlloc = function(AppData: Pointer; Items, Size: Cardinal): Pointer; stdcall;
  TBZFree = procedure(AppData, Block: Pointer); stdcall;
  {$ifdef USERECORDWITHMETHODS}TBZStreamRec = record
    {$else}TBZStreamRec = object{$endif}
    next_in: PAnsiChar;
    avail_in: Integer;
    total_in: Int64;
    next_out: PAnsiChar;
    avail_out: Integer;
    total_out: Int64;
    State: Pointer;
    zalloc: TBZAlloc;
    zfree: TBZFree;
    AppData: Pointer;
    procedure Init;
  end;

  TBZBuffer = array[word] of byte;
  TBZCompressor = class(TStream)
  private
    FInitialized: Boolean;
    FStrm: TBZStreamRec;
    FDestStream: TStream;
    SrcLen, DestLen: Cardinal;
    FBufferIn: TBZBuffer;
    BufferOut: ^TBZBuffer; // via Getmem() for AES 16-bytes alignment
    procedure FlushBufferOut;
  protected
    // override for crc or encryption, e.g.
    procedure WriteDest(const Buffer; Count: Longint); virtual;
  public
    constructor Create(outStream: TStream; CompressionLevel: Integer=6);
    destructor Destroy; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure Finish;
    property FullSize: cardinal read SrcLen;
    property CompressedSize: cardinal read DestLen;
  end;

  TBZDecompressor = class(TStream)
  private
    FReachedEnd,
    FInitialized: Boolean;
    FStrm: TBZStreamRec;
    FSrcStream: TStream;
    DestLen: Cardinal;
    FBufferIn: array[word] of byte; // one 64kb buffers
  public
    constructor Create(inStream: TStream);
    destructor Destroy; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    property FullSize: cardinal read DestLen;
  end;


/// result=nil if error decompressing
function UnCompressBzDll(Source: PAnsiChar;
  SourceSize, DestSize: integer): TMemoryStream; overload;

/// Dest must already be allocated with enough place (DestSize); return true if ok
function UnCompressBzDll(Source: PAnsiChar; SourceSize: integer;
  Dest: PAnsiChar; Destsize: integer): boolean; overload;

// raw BZ2 functions:

{$ifdef USEBZAASM}
function BZ2_bzDecompressInit(var strm: TBZStreamRec;
    verbosity, small: Integer): Integer; cdecl;
function BZ2_bzDecompress(var strm: TBZStreamRec): Integer; cdecl;
function BZ2_bzDecompressEnd(var strm: TBZStreamRec): Integer; cdecl;
{$endif}

{$ifdef MSWINDOWS}
function BZCompressorInit: boolean;
{$ifdef USEBZAASM}
const BZDeCompressorInit = true;
{$else}
function BZDeCompressorInit: boolean;
{$endif}
{$endif}

var
{$ifdef MSWINDOWS}
  BZ2_bzCompressInit: function(var strm: TBZStreamRec;
    blockSize100k, verbosity, workFactor: Integer): Integer; stdcall = nil;
  BZ2_bzCompress: function(var strm: TBZStreamRec;
    action: Integer): Integer; stdcall = nil;
  BZ2_bzCompressEnd: function(var strm: TBZStreamRec): Integer; stdcall = nil;

{$ifndef USEBZAASM}
  BZ2_bzDecompressInit: function(var strm: TBZStreamRec;
    verbosity, small: Integer): Integer; stdcall = nil;
  BZ2_bzDecompress: function(var strm: TBZStreamRec): Integer; stdcall = nil;
  BZ2_bzDecompressEnd: function(var strm: TBZStreamRec): Integer; stdcall = nil;
{$endif}

{$else}
const
  bzlib='libbz2.so';

function BZ2_bzCompressInit(var strm: TBZStreamRec;
    blockSize100k, verbosity, workFactor: Integer): Integer; cdecl;
    external bzlib name 'BZ2_bzCompressInit';
function BZ2_bzCompress(var strm: TBZStreamRec;
    action: Integer): Integer; cdecl;
    external bzlib name 'BZ2_bzCompress';
function BZ2_bzCompressEnd(var strm: TBZStreamRec): Integer; cdecl;
    external bzlib name 'BZ2_bzCompressEnd';

{$ifndef USEBZAASM}
function BZ2_bzDecompressInit(var strm: TBZStreamRec;
    verbosity, small: Integer): Integer; cdecl;
    external bzlib name 'BZ2_bzDecompressInit';
function BZ2_bzDecompress(var strm: TBZStreamRec): Integer; cdecl;
    external bzlib name 'BZ2_bzDecompress';
function BZ2_bzDecompressEnd(var strm: TBZStreamRec): Integer; cdecl;
    external bzlib name 'BZ2_bzDecompressEnd';
{$endif}
{$endif}

const
  BZ_RUN              = 0;
  BZ_FLUSH            = 1;
  BZ_FINISH           = 2;

  BZ_OK               = 0;
  BZ_RUN_OK           = 1;
  BZ_FLUSH_OK         = 2;
  BZ_FINISH_OK        = 3;
  BZ_STREAM_END       = 4;
  BZ_SEQUENCE_ERROR   = (-1);
  BZ_PARAM_ERROR      = (-2);
  BZ_MEM_ERROR        = (-3);
  BZ_DATA_ERROR       = (-4);
  BZ_DATA_ERROR_MAGIC = (-5);
  BZ_IO_ERROR         = (-6);
  BZ_UNEXPECTED_EOF   = (-7);
  BZ_OUTBUFF_FULL     = (-8);
  BZ_CONFIG_ERROR     = (-9);

function Bz2Check(const Code: Integer; const ValidCodes: array of Integer): integer;


implementation

const
  SBzlibDataError = 'bzlib: Compressed data is corrupted';
  SBzlibInternalErrorN = 'bzlib: Internal error. Code %d';

{$ifdef USEBZAASM}
{$I bunzipasm.inc} // all asm code extracted from bunzip.dll :)
{$endif}

{$ifdef MSWINDOWS}
var BZCompressModule:   HMODULE = 0;
    BZDecompressModule: HMODULE = 0;

function BZInitCompressFunctions(Module: HMODULE): Boolean;
begin
  BZCompressModule := Module;
  if Module=0 then
    Result := false else begin
    BZ2_bzCompressInit := GetProcAddress(Module, 'BZ2_bzCompressInit');
    BZ2_bzCompress := GetProcAddress(Module, 'BZ2_bzCompress');
    BZ2_bzCompressEnd := GetProcAddress(Module, 'BZ2_bzCompressEnd');
    Result := Assigned(BZ2_bzCompressInit) and Assigned(BZ2_bzCompress) and
      Assigned(BZ2_bzCompressEnd);
  end;
  if not Result then begin
    BZ2_bzCompressInit := nil;
    BZ2_bzCompress := nil;
    BZ2_bzCompressEnd := nil;
  end;
end;

{$ifndef USEBZAASM}
function BZInitDecompressFunctions: Boolean;
var F: string;
begin
  result := false;
  F := ExtractFilePath(paramstr(0))+'bunzip.dll';
  if FileExists(F) then
    BZDeCompressModule:= LoadLibrary(PChar(F)) else
    exit;
  if BZDeCompressModule=0 then
    exit;
  BZ2_bzDecompressInit := GetProcAddress(BZDeCompressModule, 'BZ2_bzDecompressInit');
  BZ2_bzDecompress := GetProcAddress(BZDeCompressModule, 'BZ2_bzDecompress');
  BZ2_bzDecompressEnd := GetProcAddress(BZDeCompressModule, 'BZ2_bzDecompressEnd');
  result := Assigned(BZ2_bzDecompressInit) and Assigned(BZ2_bzDecompress) and
    Assigned(BZ2_bzDecompressEnd);
  if not result then begin
    BZ2_bzDecompressInit := nil;
    BZ2_bzDecompress := nil;
    BZ2_bzDecompressEnd := nil;
  end;
end;
{$endif}
{$endif}

function BZAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer; stdcall;
begin
  GetMem(Result, Items * Size);
end;

procedure BZFreeMem(AppData, Block: Pointer); stdcall;
begin
  FreeMem(Block);
end;

function Bz2Check(const Code: Integer; const ValidCodes: array of Integer): integer;
var I: Integer;
begin
  if Code = BZ_MEM_ERROR then
    OutOfMemoryError;
  Result := Code;
  for I := Low(ValidCodes) to High(ValidCodes) do
    if ValidCodes[I] = Code then
      Exit;
  raise Exception.CreateFmt(SBzlibInternalErrorN, [Code]);
end;

{$ifdef MSWINDOWS}
function BZCompressorInit: boolean;
var F: string;
begin
  result := true;
  if @BZ2_bzCompressInit=nil then begin
    F := extractfilepath(paramstr(0))+'bzip.dll';
    if FileExists(F) then
      result := BZInitCompressFunctions(LoadLibrary(PChar(F))) else
      result := false;
  end;
end;

{$ifndef USEBZAASM}
function BZDeCompressorInit: boolean;
begin
  if (@BZ2_bzDecompressInit=nil) then
    result := BZInitDecompressFunctions else
    result := true;
end;
{$endif}
{$endif}


{ TBZCompressor }

constructor TBZCompressor.Create(outStream: TStream; CompressionLevel: Integer);
begin
{$ifdef MSWINDOWS}
  BZCompressorInit;
  if @BZ2_bzCompressInit=nil then
    CompressionLevel := -1; // <0 -> direct copy (no compression)
{$endif}
  FDestStream := outStream;
  FStrm.Init;
  New(BufferOut);
  with FStrm do begin
    next_out := PAnsiChar(BufferOut);
    avail_out := SizeOf(BufferOut^);
    next_in := @FBufferIn;
  end;
  if CompressionLevel>=0 then // FInitialized=false -> direct copy
    FInitialized := Bz2Check(BZ2_bzCompressInit(FStrm, CompressionLevel, 0, 0),
      [BZ_OK])=BZ_OK;
end;

destructor TBZCompressor.Destroy;
begin
  if FInitialized then begin
    FStrm.next_out := nil;
    FStrm.avail_out := 0;
    BZ2_bzCompressEnd(FStrm);
    FreeMem(BufferOut);
  end;
  inherited;
end;

procedure TBZCompressor.Finish;
begin
  if self=nil then
    exit;
  if FInitialized then begin
    while FStrm.avail_in > 0 do begin
      Bz2Check(BZ2_bzCompress(FStrm, BZ_RUN), [BZ_RUN_OK]);
      if FStrm.avail_out = 0 then FlushBufferOut;
    end;
    FStrm.next_in := nil;
    FStrm.avail_in := 0;
    while Bz2Check(BZ2_bzCompress(FStrm, BZ_FINISH), [BZ_FINISH_OK, BZ_STREAM_END])<>BZ_STREAM_END do
      FlushBufferOut;
  end;
  FlushBufferOut;
end;

procedure TBZCompressor.FlushBufferOut;
var Count: integer;
begin
//  if not FInitialized then exit;
  Count := SizeOf(BufferOut^) - FStrm.avail_out;
  if Count=0 then exit;
  WriteDest(BufferOut^, Count);
  FStrm.next_out := PAnsiChar(BufferOut);
  FStrm.avail_out := SizeOf(BufferOut^);
end;

function TBZCompressor.Read(var Buffer; Count: Integer): Longint;
begin
  assert(false);
  result := 0;
end;

function TBZCompressor.Seek(Offset: Integer; Origin: Word): Longint;
begin
  if not FInitialized then // CompressionLevel<0: direct copy to
    result := 0 else
  if (Offset = 0) and (Origin = soFromCurrent) then // for TStream.Position
    Result := FStrm.total_out else begin
    Result := 0;
    assert((Offset = 0) and (Origin = soFromBeginning) and (FStrm.total_out = 0));
  end;
end;

function TBZCompressor.Write(const Buffer; Count: Integer): Longint;
var i: integer;
    p: PAnsiChar;
begin
  if (self<>nil) and (Count>0) then begin
    result := Count;
    inc(SrcLen,Count);
    if FInitialized then begin
      if Count+FStrm.avail_in>sizeof(fBufferIn)-1 then begin
        while FStrm.avail_in > 0 do begin
          Bz2Check(BZ2_bzCompress(FStrm, BZ_RUN), [BZ_RUN_OK]);
          if FStrm.avail_out = 0 then
            FlushBufferOut;
        end;
        FStrm.avail_in := 0;
        FStrm.next_in := @fBufferIn;
      end;
      if Count<sizeof(fBufferIn) then begin
        move(Buffer,fBufferIn[FStrm.avail_in],Count);
        inc(FStrm.avail_in,Count);
      end else begin
        FStrm.avail_in := Count;
        FStrm.next_in := @Buffer;
        while FStrm.avail_in > 0 do begin
          Bz2Check(BZ2_bzCompress(FStrm, BZ_RUN), [BZ_RUN_OK]);
          if FStrm.avail_out = 0 then
            FlushBufferOut;
        end;
        FStrm.avail_in := 0;
        FStrm.next_in := @fBufferIn;
      end;
    end else begin // if not FIinitialized: CompressionLevel<0: direct copy to
      p := @Buffer;
      while Count>=FStrm.avail_out do begin
        FlushBufferOut;
        if Count<sizeof(BufferOut^) then
          i := Count else
          i := sizeof(BufferOut^);
        move(p^,BufferOut^,i);
        inc(p,i);
        dec(Count,i);
        dec(FStrm.avail_out,i);
      end;
      if Count>0 then begin
        move(p^,BufferOut^[sizeof(BufferOut^)-FStrm.avail_out],Count);
        dec(FStrm.avail_out,Count);
      end;
    end;
  end else
    result := 0; // self=nil
end;

procedure TBZCompressor.WriteDest(const Buffer; Count: Integer);
begin
  inc(DestLen,Count);
  FDestStream.WriteBuffer(Buffer, Count);
end;

{ TBZDecompressor }

constructor TBZDecompressor.Create(inStream: TStream);
begin
  FSrcStream := inStream;
{$ifndef USEBZAASM}
  if (@BZ2_bzDecompressInit=nil) and not BZInitDecompressFunctions then exit;
{$endif}
  FStrm.Init;
  FStrm.next_in := @FBufferIn;
  FInitialized := Bz2Check(BZ2_bzDecompressInit(FStrm, 0, 0), [BZ_OK])=BZ_OK;
end;

destructor TBZDecompressor.Destroy;
begin
  if FInitialized then begin
    FStrm.next_out := nil;
    FStrm.avail_out := 0;
    BZ2_bzDecompressEnd(FStrm);
  end;
  inherited;
end;

function TBZDecompressor.Read(var Buffer; Count: Integer): Longint;
begin
  if not FInitialized then begin // no decompression: direct copy from source
    Result := FSrcStream.Read(Buffer,Count);
    inc(DestLen,Result);
    exit;
  end;
  Result := 0;
  if FReachedEnd then { unexpected EOF }
    exit;
  FStrm.next_out := @Buffer;
  FStrm.avail_out := Count;
  while FStrm.avail_out > 0 do begin
    if FStrm.avail_in = 0 then begin
      FStrm.next_in := @FBufferIn;
      FStrm.avail_in := FSrcStream.Read(FBufferIn, SizeOf(FBufferIn));
      { Unlike zlib, bzlib does not return an error when avail_in is zero and
        it still needs input. To avoid an infinite loop, check for this. }
      if FStrm.avail_in=0 then
        exit; // leave result=0 to mark error
    end;
    case Bz2Check(BZ2_bzDecompress(FStrm),
      [BZ_OK, BZ_STREAM_END, BZ_DATA_ERROR, BZ_DATA_ERROR_MAGIC]) of
      BZ_STREAM_END: begin
        FReachedEnd := True;
        break;
      end;
      BZ_DATA_ERROR, BZ_DATA_ERROR_MAGIC:
        raise Exception.Create(SBzlibDataError);
    end;
  end;
  Result := Count-FStrm.avail_out;
  inc(DestLen,Result);
end;

function TBZDecompressor.Seek(Offset: Integer; Origin: Word): Longint;
begin
  if not FInitialized then // CompressionLevel<0: direct copy to
    result := DestLen else
    result := FStrm.total_out;
  if (Offset<>0) or (Origin<>soFromCurrent) then begin // for TStream.Position
    assert((Offset = 0) and (Origin = soFromBeginning) and (result = 0));
    Result := 0;
  end;
end;

function TBZDecompressor.Write(const Buffer; Count: Integer): Longint;
begin
  assert(false);
  result := 0;
end;

function UnCompressBzDll(Source: PAnsiChar; SourceSize, DestSize: integer): TMemoryStream; overload;
// result=nil if error decompressing
var strm: TBZStreamRec;
    res: integer;
begin
  result := nil;
{$ifndef USEBZAASM}
  if (@BZ2_bzDecompressInit=nil) and not BZInitDecompressFunctions then exit;
{$endif}
  strm.Init;
  if BZ2_bzDecompressInit(strm, 0,0)<>BZ_OK then
    exit;
  strm.next_in := Source;
  strm.avail_in := SourceSize;
  result := TMemoryStream.Create;
  result.Size := DestSize;
  strm.next_out := result.Memory;
  strm.avail_out := DestSize;
{$ifdef USEBZAASM}
  try
    res := BZ2_bzDecompress(strm);
  except
    on E: Exception do
      res := BZ_DATA_ERROR;
  end;
{$else}
  res := BZ2_bzDecompress(strm);
{$endif}
  if res<>BZ_STREAM_END then
    FreeAndNil(result);
  BZ2_bzDecompressEnd(strm);
end;

function UnCompressBzDll(Source: PAnsiChar; SourceSize: integer;
  Dest: PAnsiChar; Destsize: integer): boolean; overload;
// Dest must already be allocated with DestSize = enough place
var strm: TBZStreamRec;
    res: integer;
begin
  result := false;
{$ifndef USEBZAASM}
  if (@BZ2_bzDecompressInit=nil) and not BZInitDecompressFunctions then exit;
{$endif}
  strm.Init;
  if BZ2_bzDecompressInit(strm, 0,0)<>BZ_OK then
    exit;
  strm.next_in := Source;
  strm.avail_in := SourceSize;
  strm.next_out := Dest;
  strm.avail_out := DestSize;
{$ifdef USEBZAASM}
  try
    res := BZ2_bzDecompress(strm);
  except
    on E: Exception do
      res := BZ_DATA_ERROR;
  end;
{$else}
  res := BZ2_bzDecompress(strm);
{$endif}
  result := (res=BZ_STREAM_END);
  BZ2_bzDecompressEnd(strm);
end;

{ TBZStreamRec }

procedure TBZStreamRec.Init;
begin
  FillChar(self, SizeOf(self), 0);
{$ifdef MSWINDOWS}  // use LibC Alloc/Free on Linux
  zalloc := BZAllocMem;
  zfree := BZFreeMem;
{$endif}
end;

{$ifdef MSWINDOWS}
initialization
finalization
  if BZCompressModule<>0 then
    FreeLibrary(BZCompressModule);
  if BZDeCompressModule<>0 then
    FreeLibrary(BZDeCompressModule);
{$endif}
end.