lzma.pas

源代码

unit LZMA;

{
  Inno Setup
  Copyright (C) 1997-2004 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  Interface to the LZMA compression DLL and the LZMA SDK decompression OBJ

  Complete source code for the compression DLL can found at:
    http://cvs.jrsoftware.org/view/iscompress/lzma/
  Complete source code for the decompression OBJ can found at:
    http://cvs.jrsoftware.org/view/issrc/Projects/LzmaDecode/

  $jrsoftware: issrc/Projects/LZMA.pas,v 1.18 2004/03/26 17:49:44 jr Exp $
}

interface

{$I VERSION.INC}

uses
  Windows, SysUtils, Compress, Int64Em;

function LZMAInitCompressFunctions(Module: HMODULE): Boolean;
function LZMAGetLevel(const Value: String; var Level: Integer): Boolean;

const
  clLZMAFast = 1;
  clLZMANormal = 2;
  clLZMAMax = 3;
  clLZMAUltra = 4;

type
  TLZMAInStream = class;
  TLZMAOutStream = class;
  TLZMAProgressInfo = class;
  TLZMAWorkerThread = class;

  TLZMACompressor = class(TCustomCompressor)
  private
    FLZMAHandle: Pointer;
    FInStream: TLZMAInStream;
    FOutStream: TLZMAOutStream;
    FProgressInfo: TLZMAProgressInfo;
    FNextIn, FNextOut: Pointer;
    FAvailIn, FAvailOut: Cardinal;
    FWorkerThread: TLZMAWorkerThread;
    FEncodeFinished: BOOL;
    FEncodeResult: HRESULT;
    FLastProgressTick: DWORD;
    FBuffer: array[0..65535] of Byte;
    function FillBuffer(const FillBuf2: Boolean; Buf1: Pointer; Size1: Cardinal;
      var Buf2: Pointer; var Size2: Cardinal; var ProcessedSize: Cardinal): HRESULT;
    procedure FlushBuffer;
    function ProgressMade(const TotalBytesProcessed: Integer64): HRESULT;
    function Read(var Data; Size: Cardinal; var ProcessedSize: Cardinal): HRESULT;
    function Write(const Data; Size: Cardinal; var ProcessedSize: Cardinal): HRESULT;
    procedure WorkerThreadProc;
  public
    constructor Create(AWriteProc: TCompressorWriteProc;
      AProgressProc: TCompressorProgressProc; CompressionLevel: Integer); override;
    destructor Destroy; override;
    procedure Compress(const Buffer; Count: Longint); override;
    procedure Finish; override;
  end;

  TLZMADecompressor = class;
  TLZMADecompressorCallbackData = record
    Callback: Pointer;
    Instance: TLZMADecompressor;
  end;
  TLZMADecompressor = class(TCustomDecompressor)
  private
    FReachedEnd: Boolean;
    FCallbackData: TLZMADecompressorCallbackData;
    FLzmaInternalData: Pointer;
    FHeapBase: Pointer;
    FHeapSize: Cardinal;
    FBuffer: array[0..65535] of Byte;
    procedure DestroyHeap;
    procedure DoRead(var Buffer: Pointer; var BufferSize: Cardinal);
    procedure ProcessHeader;
  public
    destructor Destroy; override;
    procedure DecompressInto(var Buffer; Count: Longint); override;
    procedure Reset; override;
  end;

  { Internally-used interfaces }
  I7zUnknown = class
  public
    function QueryInterface(const iid; var obj): HRESULT; virtual; stdcall;
    function AddRef: Longint; virtual; stdcall;
    function Release: Longint; virtual; stdcall;
  end;
  I7zSequentialInStream = class(I7zUnknown)
  public
    function Read(var data; size: Cardinal; var processedSize: Cardinal): HRESULT; virtual; stdcall; abstract;
    function ReadPart(var data; size: Cardinal; var processedSize: Cardinal): HRESULT; virtual; stdcall; abstract;
  end;
  I7zSequentialOutStream = class(I7zUnknown)
  public
    function Write(const data; size: Cardinal; var processedSize: Cardinal): HRESULT; virtual; stdcall; abstract;
    function WritePart(const data; size: Cardinal; var processedSize: Cardinal): HRESULT; virtual; stdcall; abstract;
  end;
  I7zCompressProgressInfo = class(I7zUnknown)
  public
    function SetRatioInfo(const inSize, outSize: Integer64): HRESULT; virtual; stdcall; abstract;
  end;

  { Internally-used classes }
  TLZMAReadProc = function(var Data; Size: Cardinal; var ProcessedSize: Cardinal): HRESULT of object;
  TLZMAInStream = class(I7zSequentialInStream)
  private
    FReadProc: TLZMAReadProc;
  public
    function Read(var data; size: Cardinal; var processedSize: Cardinal): HRESULT; override;
    function ReadPart(var data; size: Cardinal; var processedSize: Cardinal): HRESULT; override;
  end;
  TLZMAWriteProc = function(const Data; Size: Cardinal; var ProcessedSize: Cardinal): HRESULT of object;
  TLZMAOutStream = class(I7zSequentialOutStream)
  private
    FWriteProc: TLZMAWriteProc;
  public
    function Write(const data; size: Cardinal; var processedSize: Cardinal): HRESULT; override;
    function WritePart(const data; size: Cardinal; var processedSize: Cardinal): HRESULT; override;
  end;
  TLZMAProgressProc = function(const TotalBytesProcessed: Integer64): HRESULT of object;
  TLZMAProgressInfo = class(I7zCompressProgressInfo)
  private
    FProgressProc: TLZMAProgressProc;
  public
    function SetRatioInfo(const inSize, outSize: Integer64): HRESULT; override;
  end;
  TLZMAWorkerThreadProc = procedure of object;
  TLZMAWorkerThread = class
  private
    FWorkerThreadProc: TLZMAWorkerThreadProc;
    FProgressProc: TCompressorProgressProc;
    FWorkerResumeEvent, FWorkerIsPausedEvent: THandle;
    FThread: THandle;
    FTerminateThread: BOOL;
    FCallProgressProc: BOOL;
    FTotalBytes, FLastTotalBytes: Integer64;
  public
    constructor Create(AWorkerThreadProc: TLZMAWorkerThreadProc;
      AProgressProc: TCompressorProgressProc);
    destructor Destroy; override;
    procedure ReturnToMain;
    procedure SwitchToWorker;
  end;

implementation

{$IFNDEF Delphi3orHigher}
{ Must include Ole2 in the 'uses' clause on D2, and after Windows, because
  it redefines E_* constants in Windows that are incorrect. E_OUTOFMEMORY,
  for example, is defined as $80000002 in Windows, instead of $8007000E. }
uses
  Ole2;
{$ENDIF}

const
  SLZMADataError = 'lzma: Compressed data is corrupted (%d)';

type
  TOutFunc = function(const P; Count: Integer): Integer; stdcall;
  TInFunc = function(var P; var Count: Integer): Integer; stdcall;

var
  LZMA_Init: function(var Handle: Pointer): HRESULT; stdcall;
  LZMA_SetProps: function(handle: Pointer; algorithm, dicSize, numFastBytes: Cardinal;
    matchFinder: PWideChar): HRESULT; stdcall;
  LZMA_Encode: function(handle: Pointer; in_stream: I7zSequentialInStream;
    out_stream: I7zSequentialOutStream; progress: I7zCompressProgressInfo): HRESULT; stdcall;
  LZMA_End: function(handle: Pointer): HRESULT; stdcall;

function LZMAInitCompressFunctions(Module: HMODULE): Boolean;
begin
  LZMA_Init := GetProcAddress(Module, 'LZMA_Init');
  LZMA_SetProps := GetProcAddress(Module, 'LZMA_SetProps');
  LZMA_Encode := GetProcAddress(Module, 'LZMA_Encode');
  LZMA_End := GetProcAddress(Module, 'LZMA_End');
  Result := Assigned(LZMA_Init) and Assigned(LZMA_SetProps) and
    Assigned(LZMA_Encode) and Assigned(LZMA_End);
  if not Result then begin
    LZMA_Init := nil;
    LZMA_SetProps := nil;
    LZMA_Encode := nil;
    LZMA_End := nil;
  end;
end;

procedure LZMAInternalError(const Msg: String);
begin
  raise ECompressInternalError.Create('lzma: ' + Msg);
end;

procedure LZMADataError(const Id: Integer);
begin
  raise ECompressDataError.CreateFmt(SLZMADataError, [Id]);
end;

function LZMAGetLevel(const Value: String; var Level: Integer): Boolean;
begin
  Result := True;
  if CompareText(Value, 'fast') = 0 then
    Level := clLZMAFast
  else if CompareText(Value, 'normal') = 0 then
    Level := clLZMANormal
  else if CompareText(Value, 'max') = 0 then
    Level := clLZMAMax
  else if CompareText(Value, 'ultra') = 0 then
    Level := clLZMAUltra
  else
    Result := False;
end;

{ TLZMAWorkerThread }

constructor TLZMAWorkerThread.Create(AWorkerThreadProc: TLZMAWorkerThreadProc;
  AProgressProc: TCompressorProgressProc);
begin
  inherited Create;
  FWorkerThreadProc := AWorkerThreadProc;
  FProgressProc := AProgressProc;
  FWorkerResumeEvent := CreateEvent(nil, False, False, nil);
  FWorkerIsPausedEvent := CreateEvent(nil, False, False, nil);
  if (FWorkerResumeEvent = 0) or (FWorkerIsPausedEvent = 0) then
    LZMAInternalError('CreateEvent failed');
end;

destructor TLZMAWorkerThread.Destroy;
begin
  if FThread <> 0 then begin
    { Resume the worker thread and wait for it to terminate }
    FTerminateThread := True;
    SetEvent(FWorkerResumeEvent);
    WaitForSingleObject(FThread, INFINITE);
    CloseHandle(FThread);
    FThread := 0;
  end;
  if FWorkerIsPausedEvent <> 0 then
    CloseHandle(FWorkerIsPausedEvent);
  if FWorkerResumeEvent <> 0 then
    CloseHandle(FWorkerResumeEvent);
  inherited;
end;

function WorkerThreadFunc(Parameter: Pointer): Integer;
begin
  try
    TLZMAWorkerThread(Parameter).FWorkerThreadProc;
  except
  end;
  Result := 0;
end;

procedure TLZMAWorkerThread.SwitchToWorker;
{ Called from main thread }
var
  ThreadID: DWORD;
  H: array[0..1] of THandle;
  Bytes: Integer64;
begin
  repeat
    FCallProgressProc := False;

    { Create worker thread, or resume existing one }
    if FThread = 0 then begin
      ResetEvent(FWorkerResumeEvent);
      ResetEvent(FWorkerIsPausedEvent);
      FThread := BeginThread(nil, 0, WorkerThreadFunc, Self, 0, ThreadID);
      if FThread = 0 then
        LZMAInternalError('BeginThread failed');
    end
    else
      SetEvent(FWorkerResumeEvent);

    { Wait until worker thread is paused }
    H[0] := FWorkerIsPausedEvent;
    H[1] := FThread;
    case WaitForMultipleObjects(2, @H, False, INFINITE) of
      WAIT_OBJECT_0 + 0: ;
      WAIT_OBJECT_0 + 1:
        begin
          { Uh oh - the worker thread has terminated?!
            We don't try to re-create the thread because a) it should never get
            here in the first place, and b) it might just die again (and then
            we'd be in an infinite loop). }
          LZMAInternalError('Worker thread terminated unexpectedly');
        end;
    else
      LZMAInternalError('WaitForMultipleObjects failed');
    end;

    { If control was returned here because ProgressProc needed to be called,
      call it then loop back }
    if FCallProgressProc and Assigned(FProgressProc) then begin
      Bytes := FTotalBytes;
      Dec6464(Bytes, FLastTotalBytes);
      FLastTotalBytes := FTotalBytes;
      FProgressProc(Bytes.Lo);
    end;
  until not FCallProgressProc;
end;

procedure TLZMAWorkerThread.ReturnToMain;
{ Called from worker thread }
begin
  SetEvent(FWorkerIsPausedEvent);
  if WaitForSingleObject(FWorkerResumeEvent, INFINITE) <> WAIT_OBJECT_0 then
    FTerminateThread := True;  { ...should never get here }
end;

{ TLZMACompressor }

constructor TLZMACompressor.Create(AWriteProc: TCompressorWriteProc;
  AProgressProc: TCompressorProgressProc; CompressionLevel: Integer);
const
  algorithm: array [clLZMAFast..clLZMAUltra] of Cardinal = (0, 1, 2, 2);
  dicSize: array [clLZMAFast..clLZMAUltra] of Cardinal = (32 shl 10, 2 shl 20, 8 shl 20, 32 shl 20);
  numFastBytes: array [clLZMAFast..clLZMAUltra] of Cardinal = (32, 32, 64, 64);
  matchFinder: array [clLZMAFast..clLZMAUltra] of PWideChar = ('HC3', 'BT4', 'BT4', 'BT4b');
begin
  inherited;
  FNextOut := @FBuffer;
  FAvailOut := SizeOf(FBuffer);
  FInStream := TLZMAInStream.Create;
  FInStream.FReadProc := Read;
  FOutStream := TLZMAOutStream.Create;
  FOutStream.FWriteProc := Write;
  FProgressInfo := TLZMAProgressInfo.Create;
  FProgressInfo.FProgressProc := ProgressMade;
  FWorkerThread := TLZMAWorkerThread.Create(WorkerThreadProc, AProgressProc);
  if LZMA_Init(FLZMAHandle) <> S_OK then
    LZMAInternalError('LZMA_Init failed');
  if (CompressionLevel < Low(algorithm)) or (CompressionLevel > High(algorithm)) then
    LZMAInternalError('TLZMACompressor.Create got invalid CompressionLevel ' + IntToStr(CompressionLevel));
  if LZMA_SetProps(FLZMAHandle, algorithm[CompressionLevel], dicSize[CompressionLevel],
     numFastBytes[CompressionLevel], matchFinder[CompressionLevel]) <> S_OK then
    LZMAInternalError('LZMA_SetProps failed');
end;