← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/utils/fppkg/fcl20/zstream.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/utils/fppkg/fcl20/zstream.pp
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
    Copyright (c) 1999-2000 by the Free Pascal development team
 
4
 
 
5
    Implementation of compression streams.
 
6
 
 
7
    See the file COPYING.FPC, included in this distribution,
 
8
    for details about the copyright.
 
9
 
 
10
    This program is distributed in the hope that it will be useful,
 
11
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
13
 
 
14
 **********************************************************************}
 
15
{$mode objfpc}
 
16
 
 
17
unit zstream;
 
18
 
 
19
 
 
20
{ ---------------------------------------------------------------------
 
21
  For linux and freebsd it's also possible to use ZLib instead
 
22
  of paszlib. You need to undefine 'usepaszlib'.
 
23
  ---------------------------------------------------------------------}
 
24
 
 
25
{$define usepaszlib}
 
26
 
 
27
 
 
28
interface
 
29
 
 
30
uses
 
31
  Sysutils, Classes
 
32
{$ifdef usepaszlib}
 
33
  ,paszlib,zbase
 
34
{$else}
 
35
  ,zlib
 
36
{$endif}
 
37
  ;
 
38
 
 
39
{$H+}
 
40
 
 
41
type
 
42
  // Error reporting.
 
43
  EZlibError = class(EStreamError);
 
44
  ECompressionError = class(EZlibError);
 
45
  EDecompressionError = class(EZlibError);
 
46
 
 
47
  TCustomZlibStream = class(TOwnerStream)
 
48
  private
 
49
    FStrmPos: Integer;
 
50
    FOnProgress: TNotifyEvent;
 
51
    FZRec: TZStream;
 
52
    FBuffer: array [Word] of Byte;
 
53
  protected
 
54
    procedure Progress(Sender: TObject); dynamic;
 
55
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
 
56
  public
 
57
    constructor Create(Strm: TStream);
 
58
  end;
 
59
 
 
60
  TCompressionLevel = (clNone, clFastest, clDefault, clMax);
 
61
 
 
62
  TCompressionStream = class(TCustomZlibStream)
 
63
  private
 
64
    function GetCompressionRate: extended;
 
65
    function CompressionCheck(code: Integer): Integer;
 
66
    procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
 
67
                          var OutBuf: Pointer; var OutBytes: Integer);
 
68
  public
 
69
    constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream; ASkipHeader : Boolean = False);
 
70
    destructor Destroy; override;
 
71
    function Read(var Buffer; Count: Longint): Longint; override;
 
72
    function Write(const Buffer; Count: Longint): Longint; override;
 
73
    function Seek(Offset: Longint; Origin: Word): Longint; override;
 
74
    property CompressionRate: extended read GetCompressionRate;
 
75
    property OnProgress;
 
76
  end;
 
77
 
 
78
  TDecompressionStream = class(TCustomZlibStream)
 
79
  private
 
80
    function DecompressionCheck(code: Integer): Integer;
 
81
    procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 
82
    OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
 
83
  public
 
84
    constructor Create(ASource: TStream; ASkipHeader : Boolean = False);
 
85
    destructor Destroy; override;
 
86
    function Read(var Buffer; Count: Longint): Longint; override;
 
87
    function Write(const Buffer; Count: Longint): Longint; override;
 
88
    function Seek(Offset: Longint; Origin: Word): Longint; override;
 
89
    property OnProgress;
 
90
  end;
 
91
 
 
92
  TGZOpenMode = (gzOpenRead,gzOpenWrite);
 
93
 
 
94
  TGZFileStream = Class(TStream)
 
95
    Private
 
96
    FOpenMode : TGZOpenmode;
 
97
    FFIle : gzfile;
 
98
    Public
 
99
    Constructor Create(FileName: String;FileMode: TGZOpenMode);
 
100
    Destructor Destroy;override;
 
101
    Function Read(Var Buffer; Count : longint): longint;override;
 
102
    function Write(const Buffer; Count: Longint): Longint; override;
 
103
    function Seek(Offset: Longint; Origin: Word): Longint; override;
 
104
    end;
 
105
 
 
106
 
 
107
implementation
 
108
 
 
109
Const
 
110
  ErrorStrings : array [0..6] of string =
 
111
    ('Unknown error %d','Z_ERRNO','Z_STREAM_ERROR',
 
112
     'Z_DATA_ERROR','Z_MEM_ERROR','Z_BUF_ERROR','Z_VERSION_ERROR');
 
113
  SCouldntOpenFile = 'Couldn''t open file : %s';
 
114
  SReadOnlyStream = 'Decompression streams are read-only';
 
115
  SWriteOnlyStream = 'Compression streams are write-only';
 
116
  SSeekError = 'Compression stream seek error';
 
117
  SInvalidSeek = 'Invalid Compression seek operation';
 
118
 
 
119
procedure TCompressionStream.CompressBuf(const InBuf: Pointer; InBytes: Integer;
 
120
                      var OutBuf: Pointer; var OutBytes: Integer);
 
121
var
 
122
  strm: TZStream;
 
123
  P: Pointer;
 
124
begin
 
125
  FillChar(strm, sizeof(strm), 0);
 
126
  OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
 
127
  OutBuf:=GetMem(OutBytes);
 
128
  try
 
129
    strm.next_in := InBuf;
 
130
    strm.avail_in := InBytes;
 
131
    strm.next_out := OutBuf;
 
132
    strm.avail_out := OutBytes;
 
133
    CompressionCheck(deflateInit(strm, Z_BEST_COMPRESSION));
 
134
    try
 
135
      while CompressionCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
 
136
      begin
 
137
        P := OutBuf;
 
138
        Inc(OutBytes, 256);
 
139
        ReallocMem(OutBuf,OutBytes);
 
140
        strm.next_out := PByte(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 
141
        strm.avail_out := 256;
 
142
      end;
 
143
    finally
 
144
      CompressionCheck(deflateEnd(strm));
 
145
    end;
 
146
    ReallocMem(OutBuf,strm.total_out);
 
147
    OutBytes := strm.total_out;
 
148
  except
 
149
    FreeMem(OutBuf);
 
150
    raise;
 
151
  end;
 
152
end;
 
153
 
 
154
 
 
155
procedure TDecompressionStream.DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 
156
       OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
 
157
var
 
158
  strm: TZStream;
 
159
  P: Pointer;
 
160
  BufInc: Integer;
 
161
Type
 
162
  PByte = ^Byte;
 
163
begin
 
164
  FillChar(strm, sizeof(strm), 0);
 
165
  BufInc := (InBytes + 255) and not 255;
 
166
  if OutEstimate = 0 then
 
167
    OutBytes := BufInc
 
168
  else
 
169
    OutBytes := OutEstimate;
 
170
  OutBuf:=GetMem(OutBytes);
 
171
  try
 
172
    strm.next_in := InBuf;
 
173
    strm.avail_in := InBytes;
 
174
    strm.next_out := OutBuf;
 
175
    strm.avail_out := OutBytes;
 
176
    DecompressionCheck(inflateInit(strm));
 
177
    try
 
178
      while DecompressionCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do
 
179
      begin
 
180
        P := OutBuf;
 
181
        Inc(OutBytes, BufInc);
 
182
        ReallocMem(OutBuf, OutBytes);
 
183
        strm.next_out := PByte(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 
184
        strm.avail_out := BufInc;
 
185
      end;
 
186
    finally
 
187
      DecompressionCheck(inflateEnd(strm));
 
188
    end;
 
189
    ReallocMem(OutBuf, strm.total_out);
 
190
    OutBytes := strm.total_out;
 
191
  except
 
192
    FreeMem(OutBuf);
 
193
    raise;
 
194
  end;
 
195
end;
 
196
 
 
197
 
 
198
// TCustomZlibStream
 
199
 
 
200
constructor TCustomZLibStream.Create(Strm: TStream);
 
201
begin
 
202
  inherited Create(Strm);
 
203
  FStrmPos := Strm.Position;
 
204
end;
 
205
 
 
206
procedure TCustomZLibStream.Progress(Sender: TObject);
 
207
begin
 
208
  if Assigned(FOnProgress) then FOnProgress(Sender);
 
209
end;
 
210
 
 
211
 
 
212
// TCompressionStream
 
213
 
 
214
constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
 
215
  Dest: TStream; ASkipHeader : Boolean = False);
 
216
const
 
217
  Levels: array [TCompressionLevel] of ShortInt =
 
218
    (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
 
219
begin
 
220
  inherited Create(Dest);
 
221
  FZRec.next_out := @FBuffer[0];
 
222
  FZRec.avail_out := sizeof(FBuffer);
 
223
  If ASkipHeader then
 
224
    CompressionCheck(deflateInit2(FZRec, Levels[CompressionLevel],Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0))
 
225
  else
 
226
    CompressionCheck(deflateInit(FZRec, Levels[CompressionLevel]));
 
227
end;
 
228
 
 
229
destructor TCompressionStream.Destroy;
 
230
begin
 
231
  FZRec.next_in := nil;
 
232
  FZRec.avail_in := 0;
 
233
  try
 
234
    if Source.Position <> FStrmPos then Source.Position := FStrmPos;
 
235
    while (CompressionCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
 
236
      and (FZRec.avail_out = 0) do
 
237
    begin
 
238
      Source.WriteBuffer(FBuffer, sizeof(FBuffer));
 
239
      FZRec.next_out := @FBuffer[0];
 
240
      FZRec.avail_out := sizeof(FBuffer);
 
241
    end;
 
242
    if FZRec.avail_out < sizeof(FBuffer) then
 
243
      Source.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
 
244
  finally
 
245
    deflateEnd(FZRec);
 
246
  end;
 
247
  inherited Destroy;
 
248
end;
 
249
 
 
250
function TCompressionStream.CompressionCheck(code: Integer): Integer;
 
251
begin
 
252
  Result := code;
 
253
  if (code < 0) then
 
254
    if code < -6 then
 
255
      raise ECompressionError.CreateFmt(Errorstrings[0],[Code])
 
256
    else
 
257
      raise ECompressionError.Create(ErrorStrings[Abs(Code)]);
 
258
end;
 
259
 
 
260
 
 
261
function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
 
262
begin
 
263
  raise ECompressionError.Create('Invalid stream operation');
 
264
  result:=0;
 
265
end;
 
266
 
 
267
function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
 
268
begin
 
269
  FZRec.next_in := @Buffer;
 
270
  FZRec.avail_in := Count;
 
271
  if Source.Position <> FStrmPos then Source.Position := FStrmPos;
 
272
  while (FZRec.avail_in > 0) do
 
273
  begin
 
274
    CompressionCheck(deflate(FZRec, 0));
 
275
    if FZRec.avail_out = 0 then
 
276
    begin
 
277
      Source.WriteBuffer(FBuffer, sizeof(FBuffer));
 
278
      FZRec.next_out := @FBuffer[0];
 
279
      FZRec.avail_out := sizeof(FBuffer);
 
280
      FStrmPos := Source.Position;
 
281
      Progress(Self);
 
282
    end;
 
283
  end;
 
284
  Result := Count;
 
285
end;
 
286
 
 
287
function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 
288
begin
 
289
  if (Offset = 0) and (Origin = soFromCurrent) then
 
290
    Result := FZRec.total_in
 
291
  else
 
292
    raise ECompressionError.Create(SInvalidSeek);
 
293
end;
 
294
 
 
295
function TCompressionStream.GetCompressionRate: extended;
 
296
begin
 
297
  Result:=0.0;
 
298
{  With FZrec do
 
299
    if total_in = 0 then
 
300
      GetCompressionRate:=0.0
 
301
    else
 
302
      GetCompressionRate:=1.0E2*(1.0E0-(total_out/total_in));
 
303
}
 
304
end;
 
305
 
 
306
 
 
307
// TDecompressionStream
 
308
 
 
309
constructor TDecompressionStream.Create(ASource: TStream; ASkipHeader : Boolean = False);
 
310
begin
 
311
  inherited Create(ASource);
 
312
  FZRec.next_in := @FBuffer[0];
 
313
  If ASkipHeader then
 
314
    DeCompressionCheck(inflateInit2(FZRec,-MAX_WBITS))
 
315
  else
 
316
    DeCompressionCheck(inflateInit(FZRec));
 
317
end;
 
318
 
 
319
destructor TDecompressionStream.Destroy;
 
320
begin
 
321
  if FZRec.avail_in <> 0 then
 
322
    Source.Seek(-FZRec.avail_in, soFromCurrent);
 
323
  inflateEnd(FZRec);
 
324
  inherited Destroy;
 
325
end;
 
326
 
 
327
function TDecompressionStream.DecompressionCheck(code: Integer): Integer;
 
328
begin
 
329
  Result := code;
 
330
  If Code<0 then
 
331
    if code < -6 then
 
332
      raise EDecompressionError.CreateFmt(Errorstrings[0],[Code])
 
333
    else
 
334
      raise EDecompressionError.Create(ErrorStrings[Abs(Code)]);
 
335
end;
 
336
 
 
337
function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
 
338
begin
 
339
  FZRec.next_out := @Buffer;
 
340
  FZRec.avail_out := Count;
 
341
  if Source.Position <> FStrmPos then Source.Position := FStrmPos;
 
342
  while (FZRec.avail_out > 0) do
 
343
  begin
 
344
    if FZRec.avail_in = 0 then
 
345
    begin
 
346
      FZRec.avail_in := Source.Read(FBuffer, sizeof(FBuffer));
 
347
      if FZRec.avail_in = 0 then
 
348
        begin
 
349
          Result := Count - FZRec.avail_out;
 
350
          Exit;
 
351
        end;
 
352
      FZRec.next_in := @FBuffer[0];
 
353
      FStrmPos := Source.Position;
 
354
      Progress(Self);
 
355
    end;
 
356
    if DeCompressionCheck(inflate(FZRec, 0)) = Z_STREAM_END then
 
357
        begin
 
358
          Result := Count - FZRec.avail_out;
 
359
          Exit;
 
360
        end;
 
361
  end;
 
362
  Result := Count;
 
363
end;
 
364
 
 
365
function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
 
366
begin
 
367
  raise EDecompressionError.Create('Invalid stream operation');
 
368
  result:=0;
 
369
end;
 
370
 
 
371
function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 
372
var
 
373
  I: Integer;
 
374
  Buf: array [0..4095] of Char;
 
375
begin
 
376
  if (Offset = 0) and (Origin = soFromBeginning) then
 
377
  begin
 
378
    DecompressionCheck(inflateReset(FZRec));
 
379
    FZRec.next_in := @FBuffer[0];
 
380
    FZRec.avail_in := 0;
 
381
    Source.Position := 0;
 
382
    FStrmPos := 0;
 
383
  end
 
384
  else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
 
385
          ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
 
386
  begin
 
387
    if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
 
388
    if Offset > 0 then
 
389
    begin
 
390
      for I := 1 to Offset div sizeof(Buf) do
 
391
        ReadBuffer(Buf, sizeof(Buf));
 
392
      ReadBuffer(Buf, Offset mod sizeof(Buf));
 
393
    end;
 
394
  end
 
395
  else
 
396
    raise EDecompressionError.Create(SInvalidSeek);
 
397
  Result := FZRec.total_out;
 
398
end;
 
399
 
 
400
// TGZFileStream
 
401
 
 
402
Constructor TGZFileStream.Create(FileName: String;FileMode: TGZOpenMode);
 
403
 
 
404
Const OpenStrings : array[TGZOpenMode] of pchar = ('rb','wb');
 
405
 
 
406
begin
 
407
   FOpenMode:=FileMode;
 
408
   FFile:=gzopen (PChar(FileName),Openstrings[FileMode]);
 
409
   If FFile=Nil then
 
410
     Raise ezlibError.CreateFmt (SCouldntOpenFIle,[FileName]);
 
411
end;
 
412
 
 
413
Destructor TGZFileStream.Destroy;
 
414
begin
 
415
  gzclose(FFile);
 
416
  Inherited Destroy;
 
417
end;
 
418
 
 
419
Function TGZFileStream.Read(Var Buffer; Count : longint): longint;
 
420
begin
 
421
  If FOpenMode=gzOpenWrite then
 
422
    Raise ezliberror.create(SWriteOnlyStream);
 
423
  Result:=gzRead(FFile,@Buffer,Count);
 
424
end;
 
425
 
 
426
function TGZFileStream.Write(const Buffer; Count: Longint): Longint;
 
427
begin
 
428
  If FOpenMode=gzOpenRead then
 
429
    Raise EzlibError.Create(SReadonlyStream);
 
430
  Result:=gzWrite(FFile,@Buffer,Count);
 
431
end;
 
432
 
 
433
function TGZFileStream.Seek(Offset: Longint; Origin: Word): Longint;
 
434
begin
 
435
  Result:=gzseek(FFile,Offset,Origin);
 
436
  If Result=-1 then
 
437
    Raise eZlibError.Create(SSeekError);
 
438
end;
 
439
 
 
440
end.