123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557 |
- unit ZLib;
- interface
- uses SysUtils, Classes;
- type
- TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
- TFree = procedure (AppData, Block: Pointer); cdecl;
-
- TZStreamRec = packed record
- next_in: PChar;
- avail_in: Integer;
- total_in: Longint;
- next_out: PChar;
- avail_out: Integer;
- total_out: Longint;
- msg: PChar;
- internal: Pointer;
- zalloc: TAlloc;
- zfree: TFree;
- AppData: Pointer;
- data_type: Integer;
- adler: Longint;
- reserved: Longint;
- end;
-
- TCustomZlibStream = class(TStream)
- private
- FStrm: TStream;
- FStrmPos: Integer;
- FOnProgress: TNotifyEvent;
- FZRec: TZStreamRec;
- FBuffer: array [Word] of Char;
- protected
- procedure Progress(Sender: TObject); dynamic;
- property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
- constructor Create(Strm: TStream);
- end;
- TCompressionLevel = (clNone, clFastest, clDefault, clMax);
- TCompressionStream = class(TCustomZlibStream)
- private
- function GetCompressionRate: Single;
- public
- constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- property CompressionRate: Single read GetCompressionRate;
- property OnProgress;
- end;
- TDecompressionStream = class(TCustomZlibStream)
- public
- constructor Create(Source: TStream);
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- property OnProgress;
- end;
- procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- out OutBuf: Pointer; out OutBytes: Integer);
- procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
- OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
- procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
- const OutBuf: Pointer; BufSize: Integer);
- const
- zlib_version = '1.2.5';
- type
- EZlibError = class(Exception);
- ECompressionError = class(EZlibError);
- EDecompressionError = class(EZlibError);
- implementation
- uses ZLibConst;
- const
- Z_NO_FLUSH = 0;
- Z_PARTIAL_FLUSH = 1;
- Z_SYNC_FLUSH = 2;
- Z_FULL_FLUSH = 3;
- Z_FINISH = 4;
- Z_OK = 0;
- Z_STREAM_END = 1;
- Z_NEED_DICT = 2;
- Z_ERRNO = (-1);
- Z_STREAM_ERROR = (-2);
- Z_DATA_ERROR = (-3);
- Z_MEM_ERROR = (-4);
- Z_BUF_ERROR = (-5);
- Z_VERSION_ERROR = (-6);
- Z_NO_COMPRESSION = 0;
- Z_BEST_SPEED = 1;
- Z_BEST_COMPRESSION = 9;
- Z_DEFAULT_COMPRESSION = (-1);
- Z_FILTERED = 1;
- Z_HUFFMAN_ONLY = 2;
- Z_RLE = 3;
- Z_DEFAULT_STRATEGY = 0;
- Z_BINARY = 0;
- Z_ASCII = 1;
- Z_UNKNOWN = 2;
- Z_DEFLATED = 8;
- procedure adler32; external;
- procedure compressBound; external;
- procedure crc32; external;
- procedure deflateInit2_; external;
- procedure deflateParams; external;
- function _malloc(Size: Integer): Pointer; cdecl;
- begin
- Result := AllocMem(Size);
- end;
- procedure _free(Block: Pointer); cdecl;
- begin
- FreeMem(Block);
- end;
- procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
- begin
- FillChar(P^, count, B);
- end;
- procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
- begin
- Move(source^, dest^, count);
- end;
- function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
- recsize: Integer): Integer; external;
- function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
- function deflateEnd(var strm: TZStreamRec): Integer; external;
- function inflateInit_(var strm: TZStreamRec; version: PChar;
- recsize: Integer): Integer; external;
- function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
- function inflateEnd(var strm: TZStreamRec): Integer; external;
- function inflateReset(var strm: TZStreamRec): Integer; external;
- function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
- begin
- Result := AllocMem(Items * Size);
- end;
- procedure zlibFreeMem(AppData, Block: Pointer); cdecl;
- begin
- FreeMem(Block);
- end;
- function CCheck(code: Integer): Integer;
- begin
- Result := code;
- if code < 0 then
- raise ECompressionError.Create('error');
- end;
- function DCheck(code: Integer): Integer;
- begin
- Result := code;
- if code < 0 then
- raise EDecompressionError.Create('error');
- end;
- procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- out OutBuf: Pointer; out OutBytes: Integer);
- var
- strm: TZStreamRec;
- P: Pointer;
- begin
- FillChar(strm, sizeof(strm), 0);
- strm.zalloc := zlibAllocMem;
- strm.zfree := zlibFreeMem;
- OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
- GetMem(OutBuf, OutBytes);
- try
- strm.next_in := InBuf;
- strm.avail_in := InBytes;
- strm.next_out := OutBuf;
- strm.avail_out := OutBytes;
- CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
- try
- while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
- begin
- P := OutBuf;
- Inc(OutBytes, 256);
- ReallocMem(OutBuf, OutBytes);
- strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
- strm.avail_out := 256;
- end;
- finally
- CCheck(deflateEnd(strm));
- end;
- ReallocMem(OutBuf, strm.total_out);
- OutBytes := strm.total_out;
- except
- FreeMem(OutBuf);
- raise
- end;
- end;
- procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
- OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
- var
- strm: TZStreamRec;
- P: Pointer;
- BufInc: Integer;
- begin
- FillChar(strm, sizeof(strm), 0);
- strm.zalloc := zlibAllocMem;
- strm.zfree := zlibFreeMem;
- BufInc := (InBytes + 255) and not 255;
- if OutEstimate = 0 then
- OutBytes := BufInc
- else
- OutBytes := OutEstimate;
- GetMem(OutBuf, OutBytes);
- try
- strm.next_in := InBuf;
- strm.avail_in := InBytes;
- strm.next_out := OutBuf;
- strm.avail_out := OutBytes;
- DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
- try
- while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do
- begin
- P := OutBuf;
- Inc(OutBytes, BufInc);
- ReallocMem(OutBuf, OutBytes);
- strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
- strm.avail_out := BufInc;
- end;
- finally
- DCheck(inflateEnd(strm));
- end;
- ReallocMem(OutBuf, strm.total_out);
- OutBytes := strm.total_out;
- except
- FreeMem(OutBuf);
- raise
- end;
- end;
- procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
- const OutBuf: Pointer; BufSize: Integer);
- var
- strm: TZStreamRec;
- begin
- FillChar(strm, sizeof(strm), 0);
- strm.zalloc := zlibAllocMem;
- strm.zfree := zlibFreeMem;
- strm.next_in := InBuf;
- strm.avail_in := InBytes;
- strm.next_out := OutBuf;
- strm.avail_out := BufSize;
- DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
- try
- if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then
- raise EZlibError.CreateRes(@sTargetBufferTooSmall);
- finally
- DCheck(inflateEnd(strm));
- end;
- end;
- constructor TCustomZLibStream.Create(Strm: TStream);
- begin
- inherited Create;
- FStrm := Strm;
- FStrmPos := Strm.Position;
- FZRec.zalloc := zlibAllocMem;
- FZRec.zfree := zlibFreeMem;
- end;
- procedure TCustomZLibStream.Progress(Sender: TObject);
- begin
- if Assigned(FOnProgress) then FOnProgress(Sender);
- end;
- constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
- Dest: TStream);
- const
- Levels: array [TCompressionLevel] of ShortInt =
- (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
- begin
- inherited Create(Dest);
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
- end;
- destructor TCompressionStream.Destroy;
- begin
- FZRec.next_in := nil;
- FZRec.avail_in := 0;
- try
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
- and (FZRec.avail_out = 0) do
- begin
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- end;
- if FZRec.avail_out < sizeof(FBuffer) then
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
- finally
- deflateEnd(FZRec);
- end;
- inherited Destroy;
- end;
- function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
- begin
- raise ECompressionError.CreateRes(@sInvalidStreamOp);
- end;
- function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
- begin
- FZRec.next_in := @Buffer;
- FZRec.avail_in := Count;
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (FZRec.avail_in > 0) do
- begin
- CCheck(deflate(FZRec, 0));
- if FZRec.avail_out = 0 then
- begin
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- FStrmPos := FStrm.Position;
- Progress(Self);
- end;
- end;
- Result := Count;
- end;
- function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
- begin
- if (Offset = 0) and (Origin = soFromCurrent) then
- Result := FZRec.total_in
- else
- raise ECompressionError.CreateRes(@sInvalidStreamOp);
- end;
- function TCompressionStream.GetCompressionRate: Single;
- begin
- if FZRec.total_in = 0 then
- Result := 0
- else
- Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
- end;
- constructor TDecompressionStream.Create(Source: TStream);
- begin
- inherited Create(Source);
- FZRec.next_in := FBuffer;
- FZRec.avail_in := 0;
- DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
- end;
- destructor TDecompressionStream.Destroy;
- begin
- FStrm.Seek(-FZRec.avail_in, 1);
- inflateEnd(FZRec);
- inherited Destroy;
- end;
- function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
- begin
- FZRec.next_out := @Buffer;
- FZRec.avail_out := Count;
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (FZRec.avail_out > 0) do
- begin
- if FZRec.avail_in = 0 then
- begin
- FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
- if FZRec.avail_in = 0 then
- begin
- Result := Count - FZRec.avail_out;
- Exit;
- end;
- FZRec.next_in := FBuffer;
- FStrmPos := FStrm.Position;
- Progress(Self);
- end;
- CCheck(inflate(FZRec, 0));
- end;
- Result := Count;
- end;
- function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
- begin
- raise EDecompressionError.CreateRes(@sInvalidStreamOp);
- end;
- function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
- var
- I: Integer;
- Buf: array [0..4095] of Char;
- begin
- if (Offset = 0) and (Origin = soFromBeginning) then
- begin
- DCheck(inflateReset(FZRec));
- FZRec.next_in := FBuffer;
- FZRec.avail_in := 0;
- FStrm.Position := 0;
- FStrmPos := 0;
- end
- else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
- ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
- begin
- if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
- if Offset > 0 then
- begin
- for I := 1 to Offset div sizeof(Buf) do
- ReadBuffer(Buf, sizeof(Buf));
- ReadBuffer(Buf, Offset mod sizeof(Buf));
- end;
- end
- else
- raise EDecompressionError.CreateRes(@sInvalidStreamOp);
- Result := FZRec.total_out;
- end;
- end.
|