1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:

unit SimpleTCPCompressor;

{*******************************************************************************
 Project       : SimpleTCP
 Filename      : SimpleTCPCompressor
 Date          : 2004-10-14
 Version       : 1.0.0.0
 Last modified : 2004-10-14
 Author        : Andreas Kreul a.k.a Udontknow
 URL           : www.xnebula.net
 Copyright     : Copyright (c) 2004 Andreas Kreul
 History       :

*******************************************************************************}


{*******************************************************************************

 Copyright (c) 2004, Andreas Kreul ["copyright holder(s)"]
 Partcopyright : Popov (function "GetTempFile", thx!)
 All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*******************************************************************************}


{*******************************************************************************

 This class implements onthefly data compression for the SimpleTCP-Components.
 If using data this data compression component, be sure to have the interceptor
 installed on both client and server, even if your are not using compression
 (CompressionLevel = clNone).

*******************************************************************************}


interface

uses SysUtils, Classes, ZLib, SimpleTCP;

type TSimpleTCPCompressor=class(TSimpleTCPInterceptor)
  private
    FCompressionLevel:TCompressionLevel;
  public
    procedure BeforeSendCommand(const Stream:TStream); override;
    procedure BeforeProcessCommand(const Stream:TStream); override;
  published
    constructor Create(AOwner:TComponent); override;
    property CompressionLevel:TCompressionLevel read FCompressionLevel write FCompressionLevel;
end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Simple Network',[TSimpleTCPCompressor]);
end;

{ TSimpleTCPCompressor }

procedure TSimpleTCPCompressor.BeforeProcessCommand(const Stream: TStream);
var SourceStream:TStream;
var DecompressStream:TStream;
var L:Cardinal;
begin
  if Stream=NIL then
    exit;
  try
    //create temporary stream
    if Stream.Size<=8*1024*1024 then
      SourceStream:=TMemoryStream.Create
    else
      SourceStream:=TFileStream.Create(GetTempFile,fmCreate);
    try
      //copy stream content to temporary stream
      Stream.Position:=0;
      SourceStream.CopyFrom(Stream,0);
      SourceStream.Position:=0;
      Stream.Position:=0;
      Stream.Size:=0;

      //decompress it to original stream
      SourceStream.ReadBuffer(L,SizeOf(L));
      DecompressStream:=TDeCompressionStream.Create(SourceStream);
      try
        Stream.CopyFrom(DecompressStream,L);
      finally
        DecompressStream.Free;
      end;
      Stream.Position:=0;

    finally
      SourceStream.Free;
    end;
  except
    On E:Exception do
      raise Exception.Create(Classname+': Could not decompress data! '+E.Message);
  end;
end;

procedure TSimpleTCPCompressor.BeforeSendCommand(const Stream: TStream);
var SourceStream:TStream;
var CompressStream:TStream;
var L:Cardinal;
begin
  if Stream=NIL then
    exit;

  L:=Stream.Size;

  //create temporary stream
  if Stream.Size<=8*1024*1024 then
    SourceStream:=TMemoryStream.Create
  else
    SourceStream:=TFileStream.Create(GetTempFile,fmCreate);
  try
    //copy content
    Stream.Position:=0;
    SourceStream.CopyFrom(Stream,0);
    SourceStream.Position:=0;
    Stream.Position:=0;
    Stream.Size:=0;

    //write compressed data to original stream
    Stream.WriteBuffer(L,SizeOf(L));
    compressStream:=TCompressionStream.Create(clMax,Stream);
    try
      CompressStream.CopyFrom(SourceStream,L);
    finally
      CompressStream.Free;
    end;
    Stream.Position:=0;

  finally
    SourceStream.Free;
  end;
end;

constructor TSimpleTCPCompressor.Create(AOwner:TComponent);
begin
  inherited;
  FCompressionLevel:=clDefault;
end;

end.                    

1:
2:
3:
4:
5:

procedure TForm3.Button1Click(Sender: TObject);
begin
client.Host:='localhost';
client.Connected:=true;
end;                    

1:
2:
3:
4:

procedure TForm2.ServerConnect(Connection: TSimpleTCPConnection);
begin
Listbox1.Items.Add(Connection.PeerIP);
end;