www.pudn.com > Indy_9_00_14_src.zip > IdCompressionIntercept.pas
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{}
{ $Log: 10107: IdCompressionIntercept.pas
{
{ Rev 1.2 11/6/2003 17:31:40 GGrieve
{ fix for server Intercept
}
{
Rev 1.1 4/3/2003 2:51:20 PM BGooijen
Now calls DeinitCompressors on disconnect
}
{
{ Rev 1.0 2002.11.12 10:33:46 PM czhower
}
unit IdCompressionIntercept;
{ This file implements an Indy intercept component that compresses a data
stream using the open-source zlib compression library. In order for this
file to compile on Windows, the follow .obj files *must* be provided as
delivered with this file:
deflate.obj
inflate.obj
inftrees.obj
trees.obj
adler32.obj
infblock.obj
infcodes.obj
infutil.obj
inffast.obj
On Linux, the shared-object file libz.so.1 *must* be available on the
system. Most modern Linux distributions include this file.
Simply set the CompressionLevel property to a value between 1 and 9 to
enable compressing of the data stream. A setting of 0(zero) disables
compression and the component is dormant. The sender *and* received must
have compression enabled in order to properly decompress the data stream.
They do *not* have to use the same CompressionLevel as long as they are
both set to a value between 1 and 9.
Original Author: Allen Bauer
This source file is submitted to the Indy project on behalf of Borland
Sofware Corporation. No warranties, express or implied are given with
this source file.
}
{
You may sometimes get the following compiler errors with this file:
IdCompressionIntercept.pas(331) Error: Incompatible types
IdCompressionIntercept.pas(152) Error: Unsatisfied forward or external declaration: '_tr_init'
IdCompressionIntercept.pas(153) Error: Unsatisfied forward or external declaration: '_tr_tally'
IdCompressionIntercept.pas(154) Error: Unsatisfied forward or external declaration: '_tr_flush_block'
IdCompressionIntercept.pas(155) Error: Unsatisfied forward or external declaration: '_tr_align'
IdCompressionIntercept.pas(156) Error: Unsatisfied forward or external declaration: '_tr_stored_block'
IdCompressionIntercept.pas(157) Error: Unsatisfied forward or external declaration: 'adler32'
IdCompressionIntercept.pas(158) Error: Unsatisfied forward or external declaration: 'inflate_blocks_new'
IdCompressionIntercept.pas(159) Error: Unsatisfied forward or external declaration: 'inflate_blocks'
IdCompressionIntercept.pas(160) Error: Unsatisfied forward or external declaration: 'inflate_blocks_reset'
IdCompressionIntercept.pas(161) Error: Unsatisfied forward or external declaration: 'inflate_blocks_free'
IdCompressionIntercept.pas(162) Error: Unsatisfied forward or external declaration: 'inflate_set_dictionary'
IdCompressionIntercept.pas(163) Error: Unsatisfied forward or external declaration: 'inflate_trees_bits'
IdCompressionIntercept.pas(164) Error: Unsatisfied forward or external declaration: 'inflate_trees_dynamic'
IdCompressionIntercept.pas(165) Error: Unsatisfied forward or external declaration: 'inflate_trees_fixed'
IdCompressionIntercept.pas(166) Error: Unsatisfied forward or external declaration: 'inflate_trees_free'
IdCompressionIntercept.pas(167) Error: Unsatisfied forward or external declaration: 'inflate_codes_new'
IdCompressionIntercept.pas(168) Error: Unsatisfied forward or external declaration: 'inflate_codes'
IdCompressionIntercept.pas(169) Error: Unsatisfied forward or external declaration: 'inflate_codes_free'
IdCompressionIntercept.pas(170) Error: Unsatisfied forward or external declaration: '_inflate_mask'
IdCompressionIntercept.pas(171) Error: Unsatisfied forward or external declaration: 'inflate_flush'
IdCompressionIntercept.pas(172) Error: Unsatisfied forward or external declaration: 'inflate_fast'
IdCompressionIntercept.pas(189) Error: Unsatisfied forward or external declaration: 'deflateInit_'
IdCompressionIntercept.pas(196) Error: Unsatisfied forward or external declaration: 'deflate'
IdCompressionIntercept.pas(203) Error: Unsatisfied forward or external declaration: 'deflateEnd'
IdCompressionIntercept.pas(213) Error: Unsatisfied forward or external declaration: 'inflateInit_'
IdCompressionIntercept.pas(220) Error: Unsatisfied forward or external declaration: 'inflate'
IdCompressionIntercept.pas(227) Error: Unsatisfied forward or external declaration: 'inflateEnd'
IdCompressionIntercept.pas(234) Error: Unsatisfied forward or external declaration: 'inflateReset'
Indy40.dpk(196) Fatal: Could not compile used unit 'IdCompressionIntercept.pas'
Do not be alarmed. This is due to a bug in DCC32 in Delphi 4, 5, 6, plus C++Builder, 4, 5, and 6.
There is a workaround for this issue. The workaround is to compile this unit separately from the other units and than build
Indy with a command such as DCC32 using the /M parameter. DO not use the /B parameter as that does force everything
to be recompiled triggering the DCC32 error.
The batch files FULLC4.BAT, FULLC5.BAT, FULLC6.BAT, FULLD4.BAT, FULLD5.BAT and FULLD6.BAT now have the workaround in them so
we recommend that you use those to build Indy.
Borland is aware of the issue.
}
interface
{$I IdCompilerDefines.inc}
{$IFDEF USEZLIBUNIT}
uses Classes, ZLib, IdException, IdTCPClient, IdGlobal, IdTCPConnection, IdIntercept;
{$ELSE}
uses Classes, IdException, IdTCPClient, IdGlobal, IdTCPConnection, IdIntercept;
{$ENDIF}
type
{$IFNDEF USEZLIBUNIT}
TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
{$IFDEF MSWINDOWS}
register;
{$ENDIF}
{$IFDEF LINUX}
cdecl;
{$ENDIF}
TFree = procedure (AppData, Block: Pointer);
{$IFDEF MSWINDOWS}
register;
{$ENDIF}
{$IFDEF LINUX}
cdecl;
{$ENDIF}
// Internal structure. Ignore.
TZStreamRec = packed record
next_in: PChar; // next input byte
avail_in: Integer; // number of bytes available at next_in
total_in: Integer; // total nb of input bytes read so far
next_out: PChar; // next output byte should be put here
avail_out: Integer; // remaining free space at next_out
total_out: Integer; // total nb of bytes output so far
msg: PChar; // last error message, NULL if no error
internal: Pointer; // not visible by applications
zalloc: TAlloc; // used to allocate the internal state
zfree: TFree; // used to free the internal state
AppData: Pointer; // private data object passed to zalloc and zfree
data_type: Integer; // best guess about the data type: ascii or binary
adler: Integer; // adler32 value of the uncompressed data
reserved: Integer; // reserved for future use
end;
{$ENDIF}
EIdCompressionException = class(EIdException);
EIdCompressorInitFailure = class(EIdCompressionException);
EIdDecompressorInitFailure = class(EIdCompressionException);
EIdCompressionError = class(EIdCompressionException);
EIdDecompressionError = class(EIdCompressionException);
TCompressionLevel = 0..9;
TIdCompressionIntercept = class(TIdConnectionIntercept)
protected
FCompressionLevel: TCompressionLevel;
FCompressRec: TZStreamRec;
FDecompressRec: TZStreamRec;
FRecvBuf: Pointer;
FRecvCount, FRecvSize: Integer;
FSendBuf: Pointer;
FSendCount, FSendSize: Integer;
procedure SetCompressionLevel(Value: TCompressionLevel);
procedure InitCompressors;
procedure DeinitCompressors;
public
destructor Destroy; override;
procedure Disconnect; override;
procedure Receive(ABuffer: TStream); override;
procedure Send(ABuffer: TStream); override;
published
property CompressionLevel: TCompressionLevel read FCompressionLevel write SetCompressionLevel;
end;
TIdServerCompressionIntercept = class(TIdServerIntercept)
private
FCompressionLevel: TCompressionLevel;
public
procedure Init; override;
function Accept(AConnection: TComponent): TIdConnectionIntercept; override;
published
property CompressionLevel: TCompressionLevel read FCompressionLevel write FCompressionLevel;
end;
implementation
uses IdResourceStrings, SysUtils;
{$IFNDEF USEZLIBUNIT}
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_DEFAULT_STRATEGY = 0;
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
zlib_Version = '1.0.4'; {Do not Localize}
{$IFDEF LINUX}
zlib = 'libz.so.1'; {Do not Localize}
{$ENDIF}
{$IFDEF MSWINDOWS}
{$L deflate.obj}
{$L inflate.obj}
{$L inftrees.obj}
{$L trees.obj}
{$L adler32.obj}
{$L infblock.obj}
{$L infcodes.obj}
{$L infutil.obj}
{$L inffast.obj}
procedure _tr_init; external;
procedure _tr_tally; external;
procedure _tr_flush_block; external;
procedure _tr_align; external;
procedure _tr_stored_block; external;
procedure adler32; external;
procedure inflate_blocks_new; external;
procedure inflate_blocks; external;
procedure inflate_blocks_reset; external;
procedure inflate_blocks_free; external;
procedure inflate_set_dictionary; external;
procedure inflate_trees_bits; external;
procedure inflate_trees_dynamic; external;
procedure inflate_trees_fixed; external;
procedure inflate_trees_free; external;
procedure inflate_codes_new; external;
procedure inflate_codes; external;
procedure inflate_codes_free; external;
procedure _inflate_mask; external;
procedure inflate_flush; external;
procedure inflate_fast; external;
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;
{$ENDIF}
// deflate compresses data
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
recsize: Integer): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'deflateInit_'; {Do not Localize}
{$ENDIF}
function deflate(var strm: TZStreamRec; flush: Integer): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'deflate'; {Do not Localize}
{$ENDIF}
function deflateEnd(var strm: TZStreamRec): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'deflateEnd'; {Do not Localize}
{$ENDIF}
// inflate decompresses data
function inflateInit_(var strm: TZStreamRec; version: PChar;
recsize: Integer): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'inflateInit_'; {Do not Localize}
{$ENDIF}
function inflate(var strm: TZStreamRec; flush: Integer): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'inflate'; {Do not Localize}
{$ENDIF}
function inflateEnd(var strm: TZStreamRec): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'inflateEnd'; {Do not Localize}
{$ENDIF}
function inflateReset(var strm: TZStreamRec): Integer;
{$IFDEF MSWINDOWS}
external;
{$ENDIF}
{$IFDEF LINUX}
cdecl; external zlib name 'inflateReset'; {Do not Localize}
{$ENDIF}
function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer;
{$IFDEF MSWINDOWS}
register;
{$ENDIF}
{$IFDEF LINUX}
cdecl;
{$ENDIF}
begin
Result := AllocMem(Items * Size);
end;
procedure zlibFreeMem(AppData, Block: Pointer);
{$IFDEF MSWINDOWS}
register;
{$ENDIF}
{$IFDEF LINUX}
cdecl;
{$ENDIF}
begin
FreeMem(Block);
end;
{$ENDIF}
{ TIdCompressionIntercept }
procedure TIdCompressionIntercept.DeinitCompressors;
begin
if Assigned(FCompressRec.zalloc) then
begin
deflateEnd(FCompressRec);
FillChar(FCompressRec, SizeOf(FCompressRec), 0);
end;
if Assigned(FDecompressRec.zalloc) then
begin
inflateEnd(FDecompressRec);
FillChar(FDecompressRec, SizeOf(FDecompressRec), 0);
end;
end;
destructor TIdCompressionIntercept.Destroy;
begin
DeinitCompressors;
FreeMem(FRecvBuf);
FreeMem(FSendBuf);
inherited;
end;
procedure TIdCompressionIntercept.Disconnect;
begin
inherited;
DeinitCompressors;
end;
procedure TIdCompressionIntercept.InitCompressors;
begin
if not Assigned(FCompressRec.zalloc) then
begin
FCompressRec.zalloc := zlibAllocMem;
FCompressRec.zfree := zlibFreeMem;
if deflateInit_(FCompressRec, FCompressionLevel, zlib_Version, SizeOf(FCompressRec)) <> Z_OK then
begin
raise EIdCompressorInitFailure.Create(RSZLCompressorInitializeFailure);
end;
end;
if not Assigned(FDecompressRec.zalloc) then
begin
FDecompressRec.zalloc := zlibAllocMem;
FDecompressRec.zfree := zlibFreeMem;
if inflateInit_(FDecompressRec, zlib_Version, SizeOf(FDecompressRec)) <> Z_OK then
begin
raise EIdDecompressorInitFailure.Create(RSZLDecompressorInitializeFailure);
end;
end;
end;
procedure TIdCompressionIntercept.Receive(ABuffer: TStream);
var
Buffer: array[0..2047] of Char;
nChars, C: Integer;
StreamEnd: Boolean;
begin
if FCompressionLevel in [1..9] then
begin
InitCompressors;
StreamEnd := False;
repeat
nChars := ABuffer.Read(Buffer, SizeOf(Buffer));
if nChars = 0 then Break;
FDecompressRec.next_in := Buffer;
FDecompressRec.avail_in := nChars;
FDecompressRec.total_in := 0;
while FDecompressRec.avail_in > 0 do
begin
if FRecvCount = FRecvSize then
begin
if FRecvSize = 0 then
FRecvSize := 2048
else
Inc(FRecvSize, 1024);
ReallocMem(FRecvBuf, FRecvSize);
end;
FDecompressRec.next_out := PChar(FRecvBuf) + FRecvCount;
C := FRecvSize - FRecvCount;
FDecompressRec.avail_out := C;
FDecompressRec.total_out := 0;
case inflate(FDecompressRec, Z_NO_FLUSH) of
Z_STREAM_END:
StreamEnd := True;
Z_STREAM_ERROR,
Z_DATA_ERROR,
Z_MEM_ERROR:
raise EIdDecompressionError.Create(RSZLDecompressionError);
end;
Inc(FRecvCount, C - FDecompressRec.avail_out);
end;
until StreamEnd;
ABuffer.Size := 0;
ABuffer.Write(FRecvBuf^, FRecvCount);
FRecvCount := 0;
end;
end;
procedure TIdCompressionIntercept.Send(ABuffer: TStream);
var
Buffer: array[0..1023] of Char;
begin
if FCompressionLevel in [1..9] then
begin
InitCompressors;
// Make sure the Send buffer is large enough to hold the input stream data
if ABuffer.Size > FSendSize then
begin
if ABuffer.Size > 2048 then
FSendSize := ABuffer.Size + (ABuffer.Size + 1023) mod 1024
else
FSendSize := 2048;
ReallocMem(FSendBuf, FSendSize);
end;
// Get the data from the input stream and save it off
FSendCount := ABuffer.Read(FSendBuf^, ABuffer.Size);
FCompressRec.next_in := FSendBuf;
FCompressRec.avail_in := FSendCount;
// reset and clear the input stream in preparation for compression
ABuffer.Size := 0;
// As long as there is still data in the send buffer, keep compressing
while FCompressRec.avail_in > 0 do
begin
FCompressRec.next_out := Buffer;
FCompressRec.avail_out := SizeOf(Buffer);
case deflate(FCompressRec, Z_SYNC_FLUSH) of
Z_STREAM_ERROR,
Z_DATA_ERROR,
Z_MEM_ERROR: raise EIdCompressionError.Create(RSZLCompressionError);
end;
// Place the compressed data back into the input stream
ABuffer.Write(Buffer, SizeOf(Buffer) - FCompressRec.avail_out);
end;
end;
end;
procedure TIdCompressionIntercept.SetCompressionLevel(Value: TCompressionLevel);
begin
if Value <> FCompressionLevel then
begin
DeinitCompressors;
if Value < 0 then Value := 0;
if Value > 9 then Value := 9;
FCompressionLevel := Value;
end;
end;
{ TIdServerCompressionIntercept }
function TIdServerCompressionIntercept.Accept(AConnection: TComponent): TIdConnectionIntercept;
begin
result := TIdCompressionIntercept.create(AConnection);
(result as TIdCompressionIntercept).FCompressionLevel := FCompressionLevel;
end;
procedure TIdServerCompressionIntercept.Init;
begin
// nothing
end;
end.