utils/uutlCompression.pas

unit uutlCompression;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit enthält Stream-Wrapper die Daten de/komprimieren.
                Teile basierend auf gzio.pas}

{$mode objfpc}{$H+}
{$TYPEDADDRESS ON}
{$WRITEABLECONST OFF}

{$DEFINE HAVE_ZLIB}
{$DEFINE HAVE_LIBLZMA}

{$IFNDEF WINDOWS}
  {$WARNING LibLZMA only supported on Windows for now}
  {$UNDEF HAVE_LIBLZMA}
{$ENDIF}

interface

uses
  Classes, SysUtils
  {$IFDEF HAVE_ZLIB}
  , zbase, zinflate, zdeflate
  {$ENDIF};

const
  Z_BUFSIZE = 16384;

type
  TutlCustomCompressedStream = class(TOwnerStream)
  private
    fWriting: boolean;
    fStartPos: Int64;
    fKnownSize: Int64;
  protected
    function GetSize: Int64; override;
    function GetTotalOut: QWord; virtual; abstract;
    function GetTotalIn: QWord; virtual; abstract;
  public
    constructor Create(ASource: TStream);
    property Writing: boolean read fWriting;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; overload;
    function Rewind: integer; virtual; abstract;
  end;

{$IFDEF HAVE_ZLIB}
const
  { gzip magic header }
  gz_magic : array[0..1] of byte = ($1F, $8B);

  { gzip flag byte }

  GZ_ASCII_FLAG  = $01; { bit 0 set: file probably ascii text }
  GZ_HEAD_CRC    = $02; { bit 1 set: header CRC present }
  GZ_EXTRA_FIELD = $04; { bit 2 set: extra field present }
  GZ_ORIG_NAME   = $08; { bit 3 set: original file name present }
  GZ_COMMENT     = $10; { bit 4 set: file comment present }
  GZ_RESERVED    = $E0; { bits 5..7: reserved }

  { gzip os code byte }

  GZ_OS_FAT       = $00;
  GZ_OS_AMIGA     = $01;
  GZ_OS_VMS       = $02;
  GZ_OS_UNIX      = $03;
  GZ_OS_VMCMS     = $04;
  GZ_OS_ATARI_TOS = $05;
  GZ_OS_HPFS      = $06;
  GZ_OS_MACINTOSH = $07;
  GZ_OS_ZSYSTEM   = $08;
  GZ_OS_CPM       = $09;
  GZ_OS_TOPS20    = $0A;
  GZ_OS_NTFS      = $0B;
  GZ_OS_QDOS      = $0C;
  GZ_OS_ACORNRISC = $0D;
  GZ_OS_UNKNOWN   = $FF;

type
  TutlCustomZLibStream = class(TutlCustomCompressedStream)
  private
    fStream: z_stream;
    fMode: Char;
    fLevel: Integer;
    fStrategy: Integer;
    fBuffer: array[0..Z_BUFSIZE-1] of Byte;
    fBufStart: Pointer;
  protected
    function zlibInitRead: LongInt; virtual; abstract;
    function zlibInitWrite: LongInt; virtual; abstract;
    function zlibFinishRead: LongInt; virtual;
    function zlibFinishWrite: LongInt; virtual;
    function DoFlush(flags: integer): integer;
    function GetTotalIn: QWord; override;
    function GetTotalOut: QWord; override;
  public
    constructor Create(aBaseStream: TStream; aMode: string);
    destructor Destroy; override;
    property Mode: Char read fMode;
    property Level: Integer read fLevel;
    property Strategy: Integer read fStrategy;

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    procedure Flush(flags: integer);
    function Rewind: integer; override;
  end;

  TutlZLibStream = class(TutlCustomZLibStream)
  protected
    function zlibInitRead: LongInt; override;
    function zlibInitWrite: LongInt; override;
  end;

  TutlZipStream = class(TutlCustomZLibStream)
  protected
    function zlibInitRead: LongInt; override;
    function zlibInitWrite: LongInt; override;
  end;

  TGZHeader = packed record
    magic: array[0..1] of byte;
    method: Byte;
    flags: Byte;
    time: DWord;
    xflags: byte;
    oscode: byte;
  end;
  TGZFooter = packed record
    crc32: DWord;
    size: DWord;
  end;

  TutlGZipStream = class(TutlZipStream)
  private
    fOrigFileName: string;
    fComment: string;
    fOrigTimestamp: TDateTime;
    fCRC: DWord;
  protected
    function zlibInitRead: LongInt; override;
    function zlibInitWrite: LongInt; override;
    function zlibFinishWrite: LongInt; override;
    procedure WriteHeader;
    procedure CheckHeader;
  public
    constructor Create(aBaseStream: TStream; aMode: string);
    property OrigFileame: string read fOrigFileName;
    property OrigTimestamp: TDateTime read fOrigTimestamp;
    property Comment: string read fComment;
    function Write(const Buffer; Count: Longint): Longint; override;

    procedure ReadFooter;
  end;
{$ENDIF HAVE_ZLIB}

{$IFDEF HAVE_LIBLZMA}
const
  LZMA_DLL = 'liblzma.dll';
  LZMA_VER = 50020012;
  { Return values used by several functions in liblzma }
  LZMA_OK = 0;
  LZMA_STREAM_END = 1;
  LZMA_NO_CHECK = 2;
  LZMA_UNSUPPORTED_CHECK = 3;
  LZMA_GET_CHECK = 4;
  LZMA_MEM_ERROR = 5;
  LZMA_MEMLIMIT_ERROR = 6;
  LZMA_FORMAT_ERROR = 7;
  LZMA_OPTIONS_ERROR = 8;
  LZMA_DATA_ERROR = 9;
  LZMA_BUF_ERROR = 10;
  LZMA_PROG_ERROR = 11;
  { Type of the integrity check (Check ID) }
  LZMA_CHECK_NONE = 0;
  LZMA_CHECK_CRC32 = 1;
  LZMA_CHECK_CRC64 = 4;
  LZMA_CHECK_SHA256 = 10;
  { Type of the integrity check (Check ID) }
  LZMA_INDEX_ITER_ANY = 0;
  LZMA_INDEX_ITER_STREAM = 1;
  LZMA_INDEX_ITER_BLOCK = 2;
  LZMA_INDEX_ITER_NONEMPTY_BLOCK = 3;
  { The 'action' argument for lzma_code() }
  LZMA_RUN = 0;
  LZMA_SYNC_FLUSH = 1;
  LZMA_FULL_FLUSH = 2;
  LZMA_FULL_BARRIER = 4;
  LZMA_FINISH = 3;
  { Encoding }
  LZMA_PRESET_EXTREME = $80000000;
  { Decoding }
  LZMA_TELL_NO_CHECK = $01;
  LZMA_TELL_UNSUPPORTED_CHECK = $02;
  LZMA_TELL_ANY_CHECK = $04;
  LZMA_IGNORE_CHECK = $10;
  LZMA_CONCATENATED = $08;
  { Misc}
  LZMA_STREAM_HEADER_SIZE = 12;
  LZMA_BLOCK_HEADER_SIZE_MIN = 8;
  LZMA_BLOCK_HEADER_SIZE_MAX = 1024;
  LZMA_CHECK_SIZE_MAX = 64;
  LZMA_FILTERS_MAX = 4;
  LZMA_VLI_UNKNOWN: QWord = high(QWord);


type
  {$PackRecords C}
  lzma_ret = integer;
  lzma_action = integer;
  lzma_check = integer;
  lzma_reserved_enum = (_LZMA_RESERVED_ENUM);
  lzma_index_iter_mode = integer;
  lzma_vli = QWord;
  lzma_bool = ByteBool;
  {*
  * Custom functions for memory handling.
  *}
  TAlloc = function(opaque: Pointer; Items, Size: size_t): Pointer; cdecl;
  TFree = procedure(opaque, Block: Pointer); cdecl;
  lzma_allocator = record
    XZalloc : TAlloc;
    XZfree : TFree;
    opaque : pointer;
  end;
  p_lzma_allocator = ^lzma_allocator;
  {*
  * Passing data to and from liblzma.
  *}
  lzma_stream = record
    next_in : PByte; //Pointer to the next input byte.
    avail_in : size_t; //Number of available input bytes in next_in.
    total_in : QWord; //Total number of bytes read by liblzma.
    next_out : PByte; //Pointer to the next output position.
    avail_out : size_t; //Amount of free space in next_out.
    total_out : QWord; //Total number of bytes written by liblzma.
    //Custom memory allocation functions
    //In most cases this is nil which makes liblzma use
    //the standard malloc() and free().
    allocator : p_lzma_allocator; //pointer;
    //Internal state is not visible to applications.
    internal : pointer;
    //Reserved space to allow possible future extensions without
    //breaking the ABI. Excluding the initialization of this structure,
    //you should not touch these, because the names of these variables
    //may change.
    reserved_ptr1 : pointer;
    reserved_ptr2 : pointer;
    reserved_ptr3 : pointer;
    reserved_ptr4 : pointer;
    reserved_int1 : QWord;
    reserved_int2 : QWord;
    reserved_int3 : size_t;
    reserved_int4 : size_t;
    reserved_enum1 : lzma_reserved_enum;
    reserved_enum2 : lzma_reserved_enum;
  end;
  p_lzma_stream = ^lzma_stream;
  lzma_stream_flags = record
    version: DWord;
    backward_size: lzma_vli;
    check: lzma_check;
    reserved_enum  : array[1..4] of lzma_reserved_enum;
    reserved_bool : array[1..8] of lzma_bool;
    reserved_int : array[1..2] of DWord;
  end;
  p_lzma_stream_flags = ^lzma_stream_flags;
  p_lzma_index = Pointer;
  pp_lzma_index = ^p_lzma_index;
  lzma_index_iter = record
    stream: record
      flags: p_lzma_stream_flags;
      reserved_ptr1,
      reserved_ptr2,
      reserved_ptr3: Pointer;
      number,
      block_count,
      compressed_offset,
      uncompressed_offset,
      compressed_size,
      uncompressed_size,
      padding,
      reserved_vli1,
      reserved_vli2,
      reserved_vli3,
      reserved_vli4: lzma_vli;
    end;
    block: record
      number_in_file,
      compressed_file_offset,
      uncompressed_file_offset,
      number_in_stream,
      compressed_stream_offset,
      uncompressed_stream_offset,
      uncompressed_size,
      unpadded_size,
      total_size,

      reserved_vli1,
      reserved_vli2,
      reserved_vli3,
      reserved_vli4: lzma_vli;

      reserved_ptr1,
      reserved_ptr2,
      reserved_ptr3,
      reserved_ptr4: Pointer;
    end;
    internal: array[1..6] of record case byte of
      0: (p: Pointer);
      1: (s: size_t);
      2: (v: lzma_vli);
    end;
  end;
  lzma_filter = record
    id: lzma_vli;
    options: Pointer;
  end;
  p_lzma_filter = ^lzma_filter;
  lzma_block = record
    version: dword;
    header_size: DWord;
    check: lzma_check;
    compressed_size: lzma_vli;
    uncompressed_size: lzma_vli;
    filters: p_lzma_filter;
    raw_check: array [0..LZMA_CHECK_SIZE_MAX-1] of byte;
    reserved_ptr1,
    reserved_ptr2,
    reserved_ptr3: Pointer;
    reserved_int1,
    reserved_int2: DWord;
    reserved_int3,
    reserved_int4,
    reserved_int5,
    reserved_int6,
    reserved_int7,
    reserved_int8: lzma_vli;
    reserved_enum1,
    reserved_enum2,
    reserved_enum3,
    reserved_enum4: lzma_reserved_enum;
    ignore_check: lzma_bool;

    reserved_bool2,
    reserved_bool3,
    reserved_bool4,
    reserved_bool5,
    reserved_bool6,
    reserved_bool7,
    reserved_bool8: lzma_bool;
  end;
  {$PackRecords Default}

  TlibLZMA = object
    Handle: THandle;
    PascalAllocator: lzma_allocator;

    lzma_version_number: function(): DWord; cdecl;
    { Initialize .xz Stream encoder using a preset number. }
    lzma_easy_encoder: function(var strm: lzma_stream; preset: DWord; check: lzma_check): lzma_ret; cdecl;
    { Initialize .xz Stream decoder }
    lzma_stream_decoder: function(var strm: lzma_stream; memlimit: QWord; flags: DWord): lzma_ret; cdecl;
    lzma_auto_decoder: function(var strm: lzma_stream; memlimit: QWord; flags: DWord): lzma_ret; cdecl;
    {*
    * Encode or decode data.
    *
    * Once the lzma_stream has been successfully initialized (e.g. with
    * lzma_stream_encoder()), the actual encoding or decoding is done
    * using this function. The application has to update strm->next_in,
    * strm->avail_in, strm->next_out, and strm->avail_out to pass input
    * to and get output from liblzma.
    *}
    lzma_code: function(var strm: lzma_stream; action: lzma_action): lzma_ret; cdecl;
    { Free memory allocated for the coder data structures }
    lzma_end: procedure(var strm: lzma_stream); cdecl;
    { All-in-one functions }
    lzma_easy_buffer_encode: function(preset: DWord; check: lzma_check; allocator: p_lzma_allocator; in_: PChar; in_size: size_t; out_: PChar; out_pos: pointer; out_size: size_t): lzma_ret; cdecl;
    lzma_stream_buffer_decode: function(memlimit: PQWord; flags: DWord; allocator: p_lzma_allocator; in_: PChar; in_pos: pointer; in_size: size_t; out_: PChar; out_pos: pointer; out_size: size_t): lzma_ret; cdecl;
    { Stream decoding }
    lzma_stream_footer_decode: function (out options: lzma_stream_flags; fin: PByte): lzma_ret; cdecl;
    lzma_stream_header_decode: function (out options: lzma_stream_flags; fin: PByte): lzma_ret; cdecl;
    lzma_stream_flags_compare: function (var a, b: lzma_stream_flags): lzma_ret; cdecl;
    { Index access }
    lzma_index_decoder: function(var strm: lzma_stream; i: pp_lzma_index; memlimit: QWord): lzma_ret; cdecl;
    lzma_index_buffer_decode: function(var i: p_lzma_index; var memlimit: QWord; allocator: p_lzma_allocator; in_: PByte; var in_pos: size_t; in_size: size_t): lzma_ret; cdecl;
    lzma_index_uncompressed_size: function(i: p_lzma_index): lzma_vli; cdecl;
    lzma_index_end: procedure(i: p_lzma_index; allocator: p_lzma_allocator); cdecl;
    lzma_index_cat: function(dest, src: p_lzma_index; const allocator: p_lzma_allocator): lzma_ret; cdecl;
    lzma_index_stream_flags: function(i: p_lzma_index; var flags: lzma_stream_flags): lzma_ret; cdecl;
    lzma_index_stream_padding: function(i: p_lzma_index; padding: lzma_vli): lzma_ret; cdecl;
    lzma_index_total_size: function(i: p_lzma_index): lzma_vli; cdecl;
    { Index iterator }
    lzma_index_iter_init: procedure (var iter:lzma_index_iter; i: p_lzma_index); cdecl;
    lzma_index_iter_locate: function (var iter:lzma_index_iter; target: lzma_vli): lzma_bool; cdecl;
    lzma_index_iter_next: function (var iter:lzma_index_iter; mode: lzma_index_iter_mode): lzma_bool; cdecl;
    { Block access }
    lzma_block_decoder: function(var strm: lzma_stream; var i: lzma_block): lzma_ret; cdecl;
    lzma_block_header_decode: function(var i: lzma_block; const allocator: p_lzma_allocator; fin: PByte): lzma_ret; cdecl;
    lzma_block_compressed_size: function(var i: lzma_block; unpadded_size: lzma_vli): lzma_ret; cdecl;
    function lzma_block_header_size_decode(b: dword): dword;

    procedure Load;
    procedure Unload;
  end;

  TutlXZStream = class(TutlCustomCompressedStream)
  private
    fStream: lzma_stream;
    fMode: Char;
    fLevel: DWORD;
    fBuffer: array[0..Z_BUFSIZE-1] of Byte;
    fBufStart: Pointer;
  private
    fIndex: p_lzma_index;
    fStreamNr,
    fBlockNr: DWord;
    fMaxUncompBlockSize: QWord;
    fUncompPos: QWord;
    fBlock: lzma_block;
    fBlockOffs: Int64;
    fFilters: array[0..LZMA_FILTERS_MAX] of lzma_filter; // MUST be 1 entry longer than LZMA_FILTERS_MAX for LZMA_VLI_UNKNOWN terminator
  protected
    function DoFlush(flags: integer): integer;
    function GetTotalIn: QWord; override;
    function GetTotalOut: QWord; override;
    function GetPosition: Int64; override;
    procedure BlockEnd;
    function ParseIndexes: boolean;
    procedure IterateIndexes;
  public
    constructor Create(aBaseStream: TStream; aMode: string);
    destructor Destroy; override;
    property Mode: Char read fMode;
    property Level: DWORD read fLevel;

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    procedure Flush({%H-}flags: integer);
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; overload;
    function Rewind: integer; override;
  public
    class function CheckLibraryAvailable: boolean;
  end;
{$ENDIF HAVE_LIBLZMA}

resourcestring
  sInvalidMode    = 'Invalid mode specified';
  sFailedInitZLib = 'Failed to init ZLIB';
  sGZipNoHeader  = 'No GZip header found';
  sGZIPUnsupportedMethod = 'Unsupported Method';
  sLibLZMANotFound       = 'liblzma not found or bad version: %s';
  sLZMAErrorOpen         = 'Error opening XZ file';

implementation

uses
  dateutils, crc, dynlibs;

{$IFDEF HAVE_LIBLZMA}
var
  libLZMA: TlibLZMA;
{$ENDIF HAVE_LIBLZMA}

{ TutlCustomCompressedStream }

constructor TutlCustomCompressedStream.Create(ASource: TStream);
begin
  inherited Create(ASource);
  fWriting:= false;
  fStartPos:= ASource.Position;
  fKnownSize:= -1;
end;

function TutlCustomCompressedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
  ofs: Int64;
  sz : int64;
  tmp: array [0..Z_BUFSIZE-1] of byte;
begin
  if Origin = soEnd then begin
    if fWriting then begin
      if Offset <= 0 then
        // No going back
        Exit(-1)
      else
        // Current = End
        Exit(Seek(Offset, soCurrent));
    end;

    // computes size, if possible
    ofs:= GetSize - Offset;
    // if we know the size now, translate to seek from beginning
    if fKnownSize >= 0 then
      Exit(Seek(ofs, soBeginning));
    Exit(-1);
  end;

  ofs:= Offset;

  if fWriting then begin
    if Origin = soBeginning then
      dec(ofs, GetTotalOut);
    if ofs < 0 then
      Exit(-1);

    { At this point, ofs is the number of zero bytes to write. }
    FillChar({%H-}tmp[0], Z_BUFSIZE, 0);
    while (ofs > 0) do begin
      sz := Z_BUFSIZE;
      if (ofs < Z_BUFSIZE) then
        sz := ofs;

      sz:= Write(tmp[0], sz);
      if (size <= 0) then
        Exit(-1);

      dec(ofs,sz);
    end;

    Result:= GetTotalIn;
  end else begin
    { compute absolute position }
    if Origin = soCurrent then
      inc(ofs, GetTotalOut);

    if ofs < 0 then
      Exit(-1);

    { For a negative seek, rewind and use positive seek }
    if (ofs >= GetTotalOut) then
      dec(ofs, GetTotalOut)
    else if (Rewind <> 0) then begin
      Exit(-1);
    end;

    { ofs is now the number of bytes to skip. }
    while (ofs > 0) do begin
      sz := Z_BUFSIZE;
      if (ofs < Z_BUFSIZE) then
        sz := ofs;

      sz := Read(tmp[0], sz);
      if (sz <= 0) then
        Exit(-1);
      dec(ofs, sz);
    end;

    Result:= GetTotalOut;
  end;
end;

function TutlCustomCompressedStream.GetSize: Int64;
var
  tmp: array[0..Z_BUFSIZE-1] of byte;
  sz: Int64;
begin
  if fKnownSize < 0 then begin
    if fKnownSize < -1 then
      // we tried before and it was not possible
      Exit(-1);

    // read until EOF
    repeat
      sz := Read({%H-}tmp[0], Z_BUFSIZE);
      if sz < 0 then begin
        fKnownSize:= -2;
        Exit(-1);
      end;
    until sz < Z_BUFSIZE;
    fKnownSize:= GetTotalOut;
  end;
  Result:= fKnownSize;
end;

{$IFDEF HAVE_ZLIB}

{ TutlCustomZLibStream }

constructor TutlCustomZLibStream.Create(aBaseStream: TStream; aMode: string);
var
  err: Integer;
  m: Char;
begin
  inherited Create(aBaseStream);
  fMode:= #0;
  fLevel:= Z_DEFAULT_COMPRESSION;
  fStrategy:= Z_DEFAULT_STRATEGY;
  for m in aMode do begin
    case m of
      'r',
      'w': fMode:= m;
      '0'..'9': fLevel:= Ord(m) - Ord('0');
      'f': fStrategy:= Z_FILTERED;
      'h': fStrategy:= Z_HUFFMAN_ONLY;
    end;
  end;
  if not (fMode in ['r', 'w']) then
    raise EFOpenError.Create(sInvalidMode);

  fWriting:= fMode = 'w';
  fBufStart:= @fBuffer[0];
  fStream:= Default(z_stream);
  if fWriting then begin
    err:= zlibInitWrite;
    fStream.next_out:= fBufStart;
  end else begin
    err:= zlibInitRead;
    fStream.next_in:= fBufStart;
  end;
  if err <> Z_OK then
    raise EFOpenError.Create(sFailedInitZLib);

  fStream.avail_out:= Z_BUFSIZE;
  fStartPos:= Source.Position;
end;

destructor TutlCustomZLibStream.Destroy;
begin
  if fWriting then begin
    DoFlush(Z_FINISH);
    zlibFinishWrite;
  end else begin
    zlibFinishRead;
  end;
  inherited Destroy;
end;

function TutlCustomZLibStream.Read(var Buffer; Count: Longint): Longint;
var
  res: Int64;
begin
  Result:= 0;
  fStream.next_out := @Buffer;
  fStream.avail_out := Count;
  while (fStream.avail_out > 0) do begin
    if fStream.avail_in = 0 then begin
      res:= Source.Read(fBufStart^, Z_BUFSIZE);
      if res = 0 then begin
        // reached input end, return
        Result:= Count - fStream.avail_out;
        Exit;
      end;
      fStream.avail_in := res;
      fStream.next_in := fBufStart;
    end;
    res:= inflate(fStream, Z_SYNC_FLUSH);
    if res = Z_STREAM_END then
      Exit(Count - fStream.avail_out)
    else if res < 0 then
      Exit(res);
  end;
  Result := Count;
end;

function TutlCustomZLibStream.Write(const Buffer; Count: Longint): Longint;
var
  res: int64;
begin
  fStream.next_in  := @Buffer;
  fStream.avail_in := Count;
  while (fStream.avail_in > 0) do begin
    res:= deflate(fStream, 0);
    if res < 0 then
      Exit(res);
    if fStream.avail_out = 0 then begin
      Source.WriteBuffer(fBufStart^, Z_BUFSIZE);
      fStream.next_out:= fBufStart;
      fStream.avail_out:= Z_BUFSIZE;
    end;
  end;
  Result := Count;
end;

procedure TutlCustomZLibStream.Flush(flags: integer);
begin
  DoFlush(flags);
  { TODO : Check Result}
end;

function TutlCustomZLibStream.DoFlush(flags: integer): integer;
var
  len     : cardinal;
  done    : boolean;
  written,
    err: int64;
begin
  done := false;

  if not fWriting then
    Exit(Z_STREAM_ERROR);

  fStream.avail_in := 0; { should be zero already anyway }

  while true do begin
    len := Z_BUFSIZE - fStream.avail_out;

    if (len <> 0) then begin
      written:= Source.Write(fBufStart^, len);
      if (written <> len) then begin
        Exit(Z_ERRNO);
      end;
      fStream.next_out := fBufStart;
      fStream.avail_out := Z_BUFSIZE;
    end;

    if done then
      break;
    err := deflate(fStream, flags);

    { Ignore the second of two consecutive flushes: }
    if (len = 0) and (err = Z_BUF_ERROR) then
      err := Z_OK;

    { deflate has finished flushing only when it hasn't used up
      all the available space in the output buffer: }

    done := (fStream.avail_out <> 0) or (err = Z_STREAM_END);
    if (err <> Z_OK) and (err <> Z_STREAM_END) then
      break;
  end; {WHILE}

  if (err = Z_STREAM_END) then
    Result:= Z_OK
  else
    Result:= err;
end;

function TutlCustomZLibStream.Rewind: integer;
begin
  if fWriting then
    Exit(-1);

  fStream.avail_in := 0;
  fStream.next_in := fBufStart;

  inflateReset(fStream);
  Source.Seek(fStartPos, soBeginning);
  Result:= 0;
end;

function TutlCustomZLibStream.zlibFinishRead: LongInt;
begin
  Result:= inflateEnd(fStream);
end;

function TutlCustomZLibStream.zlibFinishWrite: LongInt;
begin
  Result:= deflateEnd(fStream);
end;

function TutlCustomZLibStream.GetTotalIn: QWord;
begin
  Result:= fStream.total_in;
end;

function TutlCustomZLibStream.GetTotalOut: QWord;
begin
  Result:= fStream.total_out;
end;


{ TutlZLibStream }

function TutlZLibStream.zlibInitRead: LongInt;
begin
  Result:= inflateInit_(@fStream, ZLIB_VERSION, sizeof(fStream));
end;

function TutlZLibStream.zlibInitWrite: LongInt;
begin
  Result:= deflateInit_(@fStream, level, ZLIB_VERSION, sizeof(fStream));
end;

{ TutlZipStream }

function TutlZipStream.zlibInitRead: LongInt;
begin
  {
    Well-documented undocumented feature: passing negative window bits tells zlib not to
    excpect a zlib header and instead read raw deflate blocks.
    We use 15 bits here instead of 13 because that's what everybody else does, and it doesn't really
    matter for decompression anyway.
  }
  Result:= inflateInit2_(fStream, -MAX_WBITS, ZLIB_VERSION, sizeof(fStream));
end;

function TutlZipStream.zlibInitWrite: LongInt;
begin
  Result:= deflateInit2_(fStream, level, Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(fStream));
end;

{ TutlGZipStream }

function TutlGZipStream.zlibInitRead: LongInt;
begin
  Result:= inherited;
end;

function TutlGZipStream.zlibInitWrite: LongInt;
begin
  Result:= inherited;
end;

constructor TutlGZipStream.Create(aBaseStream: TStream; aMode: string);
begin
  inherited Create(aBaseStream, aMode);
  fOrigFileName:= '';
  fOrigTimestamp:= 0;
  fComment:= '';
  if fWriting then begin
    fCRC:= crc32(0, nil, 0);
    WriteHeader;
  end
  else begin
    CheckHeader;
  end;
  fStartPos:= Source.Position;
end;

procedure TutlGZipStream.WriteHeader;
var
  h: TGZHeader;
begin
  { TODO : use actual data }
  h.magic:= gz_magic;
  h.method:= Z_DEFLATED;
  h.flags:= 0;
  h.time:= 0;
  h.xflags:= 0;
  h.oscode:= 0;
  Source.Write(h, sizeof(h));
end;

procedure TutlGZipStream.CheckHeader;
var
  h: TGZHeader;
  w: Word;

  function ReadNullTerm: AnsiString;
  var
    b: byte;
  begin
    Result:= '';
    b:= 0;
    while Source.Read(b, sizeof(b)) = sizeof(b) do begin
      if b = 0 then break;
      Result:= Result + Chr(b);
    end;
  end;

begin
  Source.ReadBuffer(h{%H-}, sizeof(h));
  if not CompareMem(@h.magic, @gz_magic, sizeof(gz_magic)) then
    raise EFOpenError.Create(sGZipNoHeader);
  if (h.method <> Z_DEFLATED) or ((h.flags and GZ_RESERVED) <> 0) then
    raise EReadError.Create(sGZIPUnsupportedMethod);

  fOrigTimestamp:= UnixToDateTime(LEtoN(h.time));

  if (h.flags and GZ_EXTRA_FIELD) > 0 then begin
    w:= 0;
    Source.ReadBuffer(w, sizeof(w));
    w:= LEtoN(w);
    // Skip Extra Field
    Source.Seek(w, soFromCurrent);
  end;
  if (h.flags and GZ_ORIG_NAME) > 0 then begin
    fOrigFileName:= ReadNullTerm;
  end;
  if (h.flags and GZ_COMMENT) > 0 then begin
    fComment:= ReadNullTerm;
  end;
  if (h.flags and GZ_HEAD_CRC) > 0 then begin
    // Skip Header Checksum
    Source.Seek(2, soFromCurrent);
  end;
end;

function TutlGZipStream.zlibFinishWrite: LongInt;
var
  f: TGZFooter;
begin
  Result:=inherited zlibFinishWrite;
  f.crc32:= fCRC;
  f.size:= fStream.total_in;
  Source.WriteBuffer(f, sizeof(f));
end;

function TutlGZipStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result:=inherited Write(Buffer, Count);
  if Result > 0 then
    fCRC:= crc32(fCRC, @Buffer, Result);
end;

procedure TutlGZipStream.ReadFooter;
var
  bp: Int64;
  f: TGZFooter;
begin
  bp:= Source.Position;
  try
    Source.Seek(-Sizeof(f), soEnd);
    Source.ReadBuffer(f{%H-}, sizeof(f));
    fKnownSize:= f.size;
  finally
    Source.Position:= bp;
  end;
end;

{$ENDIF HAVE_ZLIB}

{$IFDEF HAVE_LIBLZMA}

{ TlibLZMA }

function TlibLZMA.lzma_block_header_size_decode(b: dword): dword;
begin
  Result:= (b + 1) * 4;
end;

function PasAlloc({%H-}opaque: Pointer; Items, Size: size_t): Pointer; cdecl;
begin
  Result:= AllocMem(Size * Items);
end;

procedure PasFree({%H-}opaque, Block: Pointer); cdecl;
begin
  Freemem(Block);
end;

procedure TlibLZMA.Load;
begin
  if Handle = 0 then
    Handle:= SafeLoadLibrary(LZMA_DLL);
  PascalAllocator.XZalloc:= @PasAlloc;
  PascalAllocator.XZfree:= @PasFree;
  if Handle <> 0 then begin
    Pointer(lzma_version_number):= GetProcedureAddress(Handle, 'lzma_version_number');
    Pointer(lzma_easy_encoder):= GetProcedureAddress(Handle, 'lzma_easy_encoder');
    Pointer(lzma_stream_decoder):= GetProcedureAddress(Handle, 'lzma_stream_decoder');
    Pointer(lzma_auto_decoder):= GetProcedureAddress(Handle, 'lzma_auto_decoder');
    Pointer(lzma_code):= GetProcedureAddress(Handle, 'lzma_code');
    Pointer(lzma_end):= GetProcedureAddress(Handle, 'lzma_end');
    Pointer(lzma_easy_buffer_encode):= GetProcedureAddress(Handle, 'lzma_easy_buffer_encode');
    Pointer(lzma_stream_buffer_decode):= GetProcedureAddress(Handle, 'lzma_stream_buffer_decode');
    Pointer(lzma_stream_footer_decode):= GetProcedureAddress(Handle, 'lzma_stream_footer_decode');
    Pointer(lzma_stream_header_decode):= GetProcedureAddress(Handle, 'lzma_stream_header_decode');
    Pointer(lzma_stream_flags_compare):= GetProcedureAddress(Handle, 'lzma_stream_flags_compare');
    Pointer(lzma_index_decoder):= GetProcedureAddress(Handle, 'lzma_index_decoder');
    Pointer(lzma_index_buffer_decode):= GetProcedureAddress(Handle, 'lzma_index_buffer_decode');
    Pointer(lzma_index_uncompressed_size):= GetProcedureAddress(Handle, 'lzma_index_uncompressed_size');
    Pointer(lzma_index_end):= GetProcedureAddress(Handle, 'lzma_index_end');
    Pointer(lzma_index_cat):= GetProcedureAddress(Handle, 'lzma_index_cat');
    Pointer(lzma_index_stream_flags):= GetProcedureAddress(Handle, 'lzma_index_stream_flags');
    Pointer(lzma_index_stream_padding):= GetProcedureAddress(Handle, 'lzma_index_stream_padding');
    Pointer(lzma_index_total_size):= GetProcedureAddress(Handle, 'lzma_index_total_size');
    Pointer(lzma_index_iter_init):= GetProcedureAddress(Handle, 'lzma_index_iter_init');
    Pointer(lzma_index_iter_locate):= GetProcedureAddress(Handle, 'lzma_index_iter_locate');
    Pointer(lzma_index_iter_next):= GetProcedureAddress(Handle, 'lzma_index_iter_next');
    Pointer(lzma_block_decoder):= GetProcedureAddress(Handle, 'lzma_block_decoder');
    Pointer(lzma_block_header_decode):= GetProcedureAddress(Handle, 'lzma_block_header_decode');
    Pointer(lzma_block_compressed_size):= GetProcedureAddress(Handle, 'lzma_block_compressed_size');
  end;
end;

procedure TlibLZMA.Unload;
begin
  UnloadLibrary(Handle);
  FillByte(Self, sizeof(Self), 0);
end;

{ TutlXZStream }

constructor TutlXZStream.Create(aBaseStream: TStream; aMode: string);
var
  m: Char;
  err: integer;
begin
  inherited Create(aBaseStream);
  if not CheckLibraryAvailable then
    raise Exception.CreateFmt(sLibLZMANotFound, [LZMA_DLL]);
  fMode:= #0;
  fLevel:= 0;
  for m in aMode do begin
    case m of
      'r',
      'w': fMode:= m;
      '0'..'9': fLevel:= Ord(m) - Ord('0');
      'e': fLevel:= fLevel or LZMA_PRESET_EXTREME;
    end;
  end;
  if not (fMode in ['r', 'w']) then
    raise EFOpenError.Create(sInvalidMode);

  fWriting:= fMode = 'w';
  fBufStart:= @fBuffer[0];
  fStream:= Default(lzma_stream);
  fBlockOffs:= -1;
  if fWriting then begin
    err:= libLZMA.lzma_easy_encoder(fStream, fLevel, LZMA_CHECK_CRC64);
    fStream.next_out:= fBufStart;
  end else begin
    if not ParseIndexes then
      raise EFOpenError.Create(sLZMAErrorOpen);
    IterateIndexes;
    fKnownSize:= libLZMA.lzma_index_uncompressed_size(fIndex);
    Seek(0, soBeginning);
    fStream.next_in:= fBufStart;
    err:= 0;
  end;
  if err <> Z_OK then
    raise EFOpenError.Create(sFailedInitZLib);

  fStream.avail_out:= Z_BUFSIZE;
  fStartPos:= Source.Position;
end;

destructor TutlXZStream.Destroy;
begin
  if fWriting then begin;
    DoFlush(LZMA_FINISH);
  end;
  libLZMA.lzma_index_end(fIndex, nil);
  libLZMA.lzma_end(fStream);
  inherited Destroy;
end;

function TutlXZStream.DoFlush(flags: integer): integer;
begin
  fStream.next_in := nil;
  fStream.avail_in := 0;
  while (libLZMA.lzma_code(fStream,flags) <> LZMA_STREAM_END) and
        (fStream.avail_out = 0) do begin
    Source.WriteBuffer(fBufStart^, Z_BUFSIZE);
    fStream.next_out := fBufStart;
    fStream.avail_out := Z_BUFSIZE;
  end;
  if fStream.avail_out < Z_BUFSIZE then
    Source.WriteBuffer(fBufStart^, Z_BUFSIZE - fStream.avail_out);
  Result:= LZMA_OK;
end;

procedure TutlXZStream.Flush(flags: integer);
begin
  DoFlush(LZMA_SYNC_FLUSH);
end;

function TutlXZStream.Read(var Buffer; Count: Longint): Longint;
var
  res, sz: Int64;
  a, b, current_read: QWord;
  r: lzma_ret;
begin
  Result:= 0;
  // is a block loaded?
  if fBlockOffs < 0 then begin
    // if no block is loaded, we might be at EOF
    Exit(0);
  end;
  fStream.next_out := @Buffer;
  fStream.avail_out := Count;
  while (fStream.avail_out > 0) do begin
    if fStream.avail_in = 0 then begin
      // read remaining data from current block
      a:= fBlock.compressed_size;
      b:= fStream.total_in;
      sz:= a - b;
      if sz > Z_BUFSIZE then
        sz:= Z_BUFSIZE;
      // if this block has no more data, read next
      if sz = 0 then begin
        // finish coding current block
        libLZMA.lzma_code(fStream, LZMA_FINISH);
        current_read:= Count - fStream.avail_out;
        Inc(Result, current_read);
        inc(fUncompPos, current_read);
        // begin new block
        res:= Seek(0, soCurrent);
        if res < 0 then
          Exit;
        // setup writing to next part
        fStream.next_out:= @Tbytearray(Buffer)[Result];
        dec(Count, current_read);
        fStream.avail_out:= Count;
        // re-read from this new block
        continue;
      end else begin
        res:= Source.Read(fBufStart^, sz);
        if res = 0 then begin
          // block should have more data, but we didn't get any
          libLZMA.lzma_code(fStream, LZMA_FINISH);
          current_read:= Count - fStream.avail_out;
          Inc(Result, current_read);
          inc(fUncompPos, current_read);
          Exit;
        end;
        fStream.avail_in := res;
        fStream.next_in := fBufStart;
      end;
    end;
    r:= libLZMA.lzma_code(fStream, LZMA_RUN);
    if r <> LZMA_OK then
      break;
  end;
  current_read:= Count - fStream.avail_out;
  Inc(Result, current_read);
  inc(fUncompPos, current_read);
end;

function TutlXZStream.Write(const Buffer; Count: Longint): Longint;
var
  res: Integer;
begin
  fStream.next_in := @Buffer;
  fStream.avail_in := Count;
  while (fStream.avail_in > 0) do begin
    res:= libLZMA.lzma_code(fStream, LZMA_RUN);
    if res < 0 then
      Exit(res);
    if fStream.avail_out = 0 then begin
      Source.WriteBuffer(fBufStart^, Z_BUFSIZE);
      fStream.next_out:= fBufStart;
      fStream.avail_out:= Z_BUFSIZE;
    end;
  end;
  Result := Count;
end;

function TutlXZStream.Rewind: integer;
begin
  if fWriting then
    Exit(-1);
  Seek(0, soBeginning);
  Result:= 0;
end;

function TutlXZStream.GetTotalIn: QWord;
begin
  Result:= fStream.total_in;
end;

function TutlXZStream.GetTotalOut: QWord;
begin
  Result:= fStream.total_out;
end;

function TutlXZStream.ParseIndexes: boolean;
const
  MAX_INDEX_LENGTH = 16384;
  MAX_QWORD        = high(QWord);
  BUFSIZE          = 16384;
var
  bp, fs: Int64;
  stream_padding: lzma_vli;
  combined_index: p_lzma_index;

  function ReadOneStream: boolean;
  var
    footer,
    header: array[0..LZMA_STREAM_HEADER_SIZE-1] of byte;
    buf: array[0..BUFSIZE-1] of byte;
    footer_flags,
    header_flags: lzma_stream_flags;
    inddec: lzma_stream;
    this_index: p_lzma_index;
    r: lzma_ret;
    index_size: lzma_vli;
  begin
    Result:= false;
    if Source.Position < LZMA_STREAM_HEADER_SIZE then
      // Corrupted File
      Exit;
    Source.Seek(-LZMA_STREAM_HEADER_SIZE, soCurrent);
    Source.ReadBuffer(footer{%H-}, sizeof(footer));

    // Skip stream padding.
    if (footer[8] = 0) and (footer[9] = 0) and (footer[10] = 0) and (footer[11] = 0) then begin
      inc(stream_padding, 4);
      Source.Seek(-4, soCurrent);
      Exit(true);
    end;

    inc(fStreamNr);
    Source.Seek(-LZMA_STREAM_HEADER_SIZE, soCurrent);

    // decode footer
    r:= libLZMA.lzma_stream_footer_decode(footer_flags, @footer[0]);
    if r <> LZMA_OK then
      Exit;
    index_size:= footer_flags.backward_size;
    // Safeguard, the index should be right before the footer
    if (index_size > MAX_INDEX_LENGTH) or (Source.Position < index_size + LZMA_STREAM_HEADER_SIZE) then
      Exit;
    // Compute start of index for this stream
    Source.Seek(-index_size, soCurrent);

    // Decode Index
    this_index:= nil;
    inddec:= Default(lzma_stream);
    r:= libLZMA.lzma_index_decoder(inddec, @this_index, MAX_QWORD);
    try
      if r <> LZMA_OK then
        Exit;
      repeat
        inddec.avail_in:= index_size;
        if inddec.avail_in > BUFSIZE then
          inddec.avail_in:= BUFSIZE;
        Source.ReadBuffer({%H-}buf[0], inddec.avail_in);
        index_size -= inddec.avail_in;
        inddec.next_in:= @buf[0];
        r:= libLZMA.lzma_code(inddec, LZMA_RUN);
      until (r <> LZMA_OK) or (index_size=0);

      if r <> LZMA_STREAM_END then
        Exit;

      index_size:= libLZMA.lzma_index_total_size(this_index);
      Source.Seek(- (inddec.total_in + index_size + LZMA_STREAM_HEADER_SIZE), soCurrent);
      // Read and decode Stream Header
      Source.ReadBuffer(header{%H-}[0], LZMA_STREAM_HEADER_SIZE);
      Source.Seek(-LZMA_STREAM_HEADER_SIZE, soCurrent);
      r:= libLZMA.lzma_stream_header_decode(header_flags, @header[0]);
      if r <> LZMA_OK then
        Exit;
      // should be equal
      r:= libLZMA.lzma_stream_flags_compare(header_flags, footer_flags);
      if r <> LZMA_OK then
        Exit;
      // store decoded flags in this index
      r:= libLZMA.lzma_index_stream_flags(this_index, footer_flags);
      if r <> LZMA_OK then
        Exit;
      // store padding accumulated so far (needed for seeking in multi-stream-files)
      r:= libLZMA.lzma_index_stream_padding(this_index, stream_padding);
      if r <> LZMA_OK then
        Exit;

      if Assigned(combined_index) then begin
        r:= libLZMA.lzma_index_cat(this_index, combined_index, nil);
        if r <> LZMA_OK then
          Exit;
      end;

      combined_index:= this_index;
      this_index:= nil;
      Result:= true;
    finally
      libLZMA.lzma_end(inddec);
      libLZMA.lzma_index_end(this_index, nil);
    end;
  end;

begin
  Result:= false;
  bp:= Source.Position;
  try
    fs:= Source.Seek(0, soEnd);
    // file size must be 4 byte aligned
    if (fs <= 0) or (fs and 3 > 0) then
      Exit;

    stream_padding:= 0;
    fStreamNr:= 0;
    combined_index:= nil;
    try
      // Jump backwards through the file identifying each stream.
      while Source.Position > 0 do begin
        if not ReadOneStream then
          Exit;
      end;
      fIndex:= combined_index;
      combined_index:= nil;
      Result:= true;
    except
      libLZMA.lzma_index_end(combined_index, nil);
    end;
  finally
    if not Result then
      Source.Position:= bp;
  end;
end;

procedure TutlXZStream.IterateIndexes;
var
  iter: lzma_index_iter;
begin
  fBlockNr:= 0;
  fMaxUncompBlockSize:= 0;

  iter:= Default(lzma_index_iter);
  libLZMA.lzma_index_iter_init(iter, fIndex);
  while not libLZMA.lzma_index_iter_next(iter, LZMA_INDEX_ITER_NONEMPTY_BLOCK) do begin
    if iter.block.uncompressed_size > fMaxUncompBlockSize then
      fMaxUncompBlockSize:= iter.block.uncompressed_size;
    inc(fBlockNr);
  end;
end;

function TutlXZStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
  iter: lzma_index_iter;
  header: array[0..LZMA_BLOCK_HEADER_SIZE_MAX-1] of byte;
  tmp: array[0..Z_BUFSIZE] of byte;
  r: lzma_ret;
  ofs, sz: Int64;
begin
  if fWriting then
    Exit(inherited Seek(Offset, Origin));

  // only support absolute position
  case Origin of
    soEnd: Exit(Seek(fKnownSize + Offset, soBeginning));
    soCurrent: Exit(Seek(Position + Offset, soBeginning));
  end;

  Result:= -1;

  if Offset = fKnownSize then begin
    // seek to last - pretend it worked, but reading will fail
     fUncompPos:= fKnownSize;
    BlockEnd;
    Exit;
  end;

  // find what block the target is in
  iter:= Default(lzma_index_iter);
  libLZMA.lzma_index_iter_init(iter, fIndex);
  if libLZMA.lzma_index_iter_locate(iter, Offset) then begin
    // not found, don't change anything
    Exit;
  end;

  if (iter.block.compressed_file_offset <> fBlockOffs) or
     (Offset < fUncompPos) then begin

    // free current Block
    BlockEnd;

    // seek to block begin
    fBlockOffs:= iter.block.compressed_file_offset;
    if Source.Seek(iter.block.compressed_file_offset, soBeginning)<0 then
      Exit;
    //Read the block header.  Start by reading a single byte which tell us how big the block header is.
    Source.ReadBuffer({%H-}header[0], 1);
    if header[0] = 0 then
      Exit;

    fBlock.version:= 0;
    fBlock.check:= iter.stream.flags^.check;
    fBlock.filters:= @fFilters[0];
    fBlock.header_size:= libLZMA.lzma_block_header_size_decode(header[0]);

    //Now read and decode the block header.
    Source.ReadBuffer(header[1], fBlock.header_size-1);

    r:= libLZMA.lzma_block_header_decode(fBlock, @libLZMA.PascalAllocator, @header[0]);
    if r <> LZMA_OK then
      Exit;

    // What this actually does is it checks that the block header matches the index.
    r:= libLZMA.lzma_block_compressed_size(fBlock, iter.block.unpadded_size);
    if r <> LZMA_OK then
      Exit;

    // copy over info we need later
    fBlock.uncompressed_size:= iter.block.uncompressed_size;

    // Read the block data.
    fStream:= Default(lzma_stream);
    r:= libLZMA.lzma_block_decoder(fStream, fBlock);
    if r <> LZMA_OK then
      Exit;

    fUncompPos:= iter.block.uncompressed_file_offset;
  end;

  // fast-forward to actual pos
  ofs:= Offset - fUncompPos;
  while (ofs > 0) do begin
    sz := Z_BUFSIZE;
    if (ofs < Z_BUFSIZE) then
      sz := ofs;

    sz := Read({%H-}tmp[0], sz);
    if (sz <= 0) then
      Exit;
    dec(ofs, sz);
  end;

  Result:= fUncompPos;
end;

function TutlXZStream.GetPosition: Int64;
begin
  if fWriting then
    Exit(inherited GetPosition);
  Result:= fUncompPos;
end;

procedure TutlXZStream.BlockEnd;
var
  i: Integer;
begin
  libLZMA.lzma_end(fStream);
  fStream:= Default(lzma_stream);
  fBlock:= Default(lzma_block);
  fBlockOffs:= -1;

  for i:= 0 to LZMA_FILTERS_MAX-1 do begin
    if fFilters[i].id <> LZMA_VLI_UNKNOWN then
      libLZMA.PascalAllocator.XZfree(nil, fFilters[i].options);
    fFilters[i].id:= LZMA_VLI_UNKNOWN;
  end;
end;

class function TutlXZStream.CheckLibraryAvailable: boolean;
begin
  libLZMA.Load;
  Result:= Assigned(libLZMA.lzma_version_number) and (libLZMA.lzma_version_number()>=LZMA_VER);
end;

{$ENDIF HAVE_LIBLZMA}

finalization
{$IFDEF HAVE_LIBLZMA}
  libLZMA.Unload;
{$ENDIF HAVE_LIBLZMA}
end.