Fossil SCM

fossil-scm / compat / zlib / contrib / delphi / ZLib.pas
Blame History Raw 558 lines
1
{*******************************************************}
2
{ }
3
{ Borland Delphi Supplemental Components }
4
{ ZLIB Data Compression Interface Unit }
5
{ }
6
{ Copyright (c) 1997,99 Borland Corporation }
7
{ }
8
{*******************************************************}
9
10
{ Updated for zlib 1.2.x by Cosmin Truta <[email protected]> }
11
12
unit ZLib;
13
14
interface
15
16
uses SysUtils, Classes;
17
18
type
19
TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
20
TFree = procedure (AppData, Block: Pointer); cdecl;
21
22
// Internal structure. Ignore.
23
TZStreamRec = packed record
24
next_in: PChar; // next input byte
25
avail_in: Integer; // number of bytes available at next_in
26
total_in: Longint; // total nb of input bytes read so far
27
28
next_out: PChar; // next output byte should be put here
29
avail_out: Integer; // remaining free space at next_out
30
total_out: Longint; // total nb of bytes output so far
31
32
msg: PChar; // last error message, NULL if no error
33
internal: Pointer; // not visible by applications
34
35
zalloc: TAlloc; // used to allocate the internal state
36
zfree: TFree; // used to free the internal state
37
AppData: Pointer; // private data object passed to zalloc and zfree
38
39
data_type: Integer; // best guess about the data type: ascii or binary
40
adler: Longint; // adler32 value of the uncompressed data
41
reserved: Longint; // reserved for future use
42
end;
43
44
// Abstract ancestor class
45
TCustomZlibStream = class(TStream)
46
private
47
FStrm: TStream;
48
FStrmPos: Integer;
49
FOnProgress: TNotifyEvent;
50
FZRec: TZStreamRec;
51
FBuffer: array [Word] of Char;
52
protected
53
procedure Progress(Sender: TObject); dynamic;
54
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
55
constructor Create(Strm: TStream);
56
end;
57
58
{ TCompressionStream compresses data on the fly as data is written to it, and
59
stores the compressed data to another stream.
60
61
TCompressionStream is write-only and strictly sequential. Reading from the
62
stream will raise an exception. Using Seek to move the stream pointer
63
will raise an exception.
64
65
Output data is cached internally, written to the output stream only when
66
the internal output buffer is full. All pending output data is flushed
67
when the stream is destroyed.
68
69
The Position property returns the number of uncompressed bytes of
70
data that have been written to the stream so far.
71
72
CompressionRate returns the on-the-fly percentage by which the original
73
data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100
74
If raw data size = 100 and compressed data size = 25, the CompressionRate
75
is 75%
76
77
The OnProgress event is called each time the output buffer is filled and
78
written to the output stream. This is useful for updating a progress
79
indicator when you are writing a large chunk of data to the compression
80
stream in a single call.}
81
82
83
TCompressionLevel = (clNone, clFastest, clDefault, clMax);
84
85
TCompressionStream = class(TCustomZlibStream)
86
private
87
function GetCompressionRate: Single;
88
public
89
constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
90
destructor Destroy; override;
91
function Read(var Buffer; Count: Longint): Longint; override;
92
function Write(const Buffer; Count: Longint): Longint; override;
93
function Seek(Offset: Longint; Origin: Word): Longint; override;
94
property CompressionRate: Single read GetCompressionRate;
95
property OnProgress;
96
end;
97
98
{ TDecompressionStream decompresses data on the fly as data is read from it.
99
100
Compressed data comes from a separate source stream. TDecompressionStream
101
is read-only and unidirectional; you can seek forward in the stream, but not
102
backwards. The special case of setting the stream position to zero is
103
allowed. Seeking forward decompresses data until the requested position in
104
the uncompressed data has been reached. Seeking backwards, seeking relative
105
to the end of the stream, requesting the size of the stream, and writing to
106
the stream will raise an exception.
107
108
The Position property returns the number of bytes of uncompressed data that
109
have been read from the stream so far.
110
111
The OnProgress event is called each time the internal input buffer of
112
compressed data is exhausted and the next block is read from the input stream.
113
This is useful for updating a progress indicator when you are reading a
114
large chunk of data from the decompression stream in a single call.}
115
116
TDecompressionStream = class(TCustomZlibStream)
117
public
118
constructor Create(Source: TStream);
119
destructor Destroy; override;
120
function Read(var Buffer; Count: Longint): Longint; override;
121
function Write(const Buffer; Count: Longint): Longint; override;
122
function Seek(Offset: Longint; Origin: Word): Longint; override;
123
property OnProgress;
124
end;
125
126
127
128
{ CompressBuf compresses data, buffer to buffer, in one call.
129
In: InBuf = ptr to compressed data
130
InBytes = number of bytes in InBuf
131
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
132
OutBytes = number of bytes in OutBuf }
133
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
134
out OutBuf: Pointer; out OutBytes: Integer);
135
136
137
{ DecompressBuf decompresses data, buffer to buffer, in one call.
138
In: InBuf = ptr to compressed data
139
InBytes = number of bytes in InBuf
140
OutEstimate = zero, or est. size of the decompressed data
141
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
142
OutBytes = number of bytes in OutBuf }
143
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
144
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
145
146
{ DecompressToUserBuf decompresses data, buffer to buffer, in one call.
147
In: InBuf = ptr to compressed data
148
InBytes = number of bytes in InBuf
149
Out: OutBuf = ptr to user-allocated buffer to contain decompressed data
150
BufSize = number of bytes in OutBuf }
151
procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
152
const OutBuf: Pointer; BufSize: Integer);
153
154
const
155
zlib_version = '1.3.2';
156
157
type
158
EZlibError = class(Exception);
159
ECompressionError = class(EZlibError);
160
EDecompressionError = class(EZlibError);
161
162
implementation
163
164
uses ZLibConst;
165
166
const
167
Z_NO_FLUSH = 0;
168
Z_PARTIAL_FLUSH = 1;
169
Z_SYNC_FLUSH = 2;
170
Z_FULL_FLUSH = 3;
171
Z_FINISH = 4;
172
173
Z_OK = 0;
174
Z_STREAM_END = 1;
175
Z_NEED_DICT = 2;
176
Z_ERRNO = (-1);
177
Z_STREAM_ERROR = (-2);
178
Z_DATA_ERROR = (-3);
179
Z_MEM_ERROR = (-4);
180
Z_BUF_ERROR = (-5);
181
Z_VERSION_ERROR = (-6);
182
183
Z_NO_COMPRESSION = 0;
184
Z_BEST_SPEED = 1;
185
Z_BEST_COMPRESSION = 9;
186
Z_DEFAULT_COMPRESSION = (-1);
187
188
Z_FILTERED = 1;
189
Z_HUFFMAN_ONLY = 2;
190
Z_RLE = 3;
191
Z_DEFAULT_STRATEGY = 0;
192
193
Z_BINARY = 0;
194
Z_ASCII = 1;
195
Z_UNKNOWN = 2;
196
197
Z_DEFLATED = 8;
198
199
200
{$L adler32.obj}
201
{$L compress.obj}
202
{$L crc32.obj}
203
{$L deflate.obj}
204
{$L infback.obj}
205
{$L inffast.obj}
206
{$L inflate.obj}
207
{$L inftrees.obj}
208
{$L trees.obj}
209
{$L uncompr.obj}
210
{$L zutil.obj}
211
212
procedure adler32; external;
213
procedure compressBound; external;
214
procedure crc32; external;
215
procedure deflateInit2_; external;
216
procedure deflateParams; external;
217
218
function _malloc(Size: Integer): Pointer; cdecl;
219
begin
220
Result := AllocMem(Size);
221
end;
222
223
procedure _free(Block: Pointer); cdecl;
224
begin
225
FreeMem(Block);
226
end;
227
228
procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
229
begin
230
FillChar(P^, count, B);
231
end;
232
233
procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
234
begin
235
Move(source^, dest^, count);
236
end;
237
238
239
240
// deflate compresses data
241
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
242
recsize: Integer): Integer; external;
243
function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
244
function deflateEnd(var strm: TZStreamRec): Integer; external;
245
246
// inflate decompresses data
247
function inflateInit_(var strm: TZStreamRec; version: PChar;
248
recsize: Integer): Integer; external;
249
function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
250
function inflateEnd(var strm: TZStreamRec): Integer; external;
251
function inflateReset(var strm: TZStreamRec): Integer; external;
252
253
254
function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
255
begin
256
// GetMem(Result, Items*Size);
257
Result := AllocMem(Items * Size);
258
end;
259
260
procedure zlibFreeMem(AppData, Block: Pointer); cdecl;
261
begin
262
FreeMem(Block);
263
end;
264
265
{function zlibCheck(code: Integer): Integer;
266
begin
267
Result := code;
268
if code < 0 then
269
raise EZlibError.Create('error'); //!!
270
end;}
271
272
function CCheck(code: Integer): Integer;
273
begin
274
Result := code;
275
if code < 0 then
276
raise ECompressionError.Create('error'); //!!
277
end;
278
279
function DCheck(code: Integer): Integer;
280
begin
281
Result := code;
282
if code < 0 then
283
raise EDecompressionError.Create('error'); //!!
284
end;
285
286
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
287
out OutBuf: Pointer; out OutBytes: Integer);
288
var
289
strm: TZStreamRec;
290
P: Pointer;
291
begin
292
FillChar(strm, sizeof(strm), 0);
293
strm.zalloc := zlibAllocMem;
294
strm.zfree := zlibFreeMem;
295
OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
296
GetMem(OutBuf, OutBytes);
297
try
298
strm.next_in := InBuf;
299
strm.avail_in := InBytes;
300
strm.next_out := OutBuf;
301
strm.avail_out := OutBytes;
302
CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
303
try
304
while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
305
begin
306
P := OutBuf;
307
Inc(OutBytes, 256);
308
ReallocMem(OutBuf, OutBytes);
309
strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
310
strm.avail_out := 256;
311
end;
312
finally
313
CCheck(deflateEnd(strm));
314
end;
315
ReallocMem(OutBuf, strm.total_out);
316
OutBytes := strm.total_out;
317
except
318
FreeMem(OutBuf);
319
raise
320
end;
321
end;
322
323
324
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
325
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
326
var
327
strm: TZStreamRec;
328
P: Pointer;
329
BufInc: Integer;
330
begin
331
FillChar(strm, sizeof(strm), 0);
332
strm.zalloc := zlibAllocMem;
333
strm.zfree := zlibFreeMem;
334
BufInc := (InBytes + 255) and not 255;
335
if OutEstimate = 0 then
336
OutBytes := BufInc
337
else
338
OutBytes := OutEstimate;
339
GetMem(OutBuf, OutBytes);
340
try
341
strm.next_in := InBuf;
342
strm.avail_in := InBytes;
343
strm.next_out := OutBuf;
344
strm.avail_out := OutBytes;
345
DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
346
try
347
while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do
348
begin
349
P := OutBuf;
350
Inc(OutBytes, BufInc);
351
ReallocMem(OutBuf, OutBytes);
352
strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
353
strm.avail_out := BufInc;
354
end;
355
finally
356
DCheck(inflateEnd(strm));
357
end;
358
ReallocMem(OutBuf, strm.total_out);
359
OutBytes := strm.total_out;
360
except
361
FreeMem(OutBuf);
362
raise
363
end;
364
end;
365
366
procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
367
const OutBuf: Pointer; BufSize: Integer);
368
var
369
strm: TZStreamRec;
370
begin
371
FillChar(strm, sizeof(strm), 0);
372
strm.zalloc := zlibAllocMem;
373
strm.zfree := zlibFreeMem;
374
strm.next_in := InBuf;
375
strm.avail_in := InBytes;
376
strm.next_out := OutBuf;
377
strm.avail_out := BufSize;
378
DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
379
try
380
if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then
381
raise EZlibError.CreateRes(@sTargetBufferTooSmall);
382
finally
383
DCheck(inflateEnd(strm));
384
end;
385
end;
386
387
// TCustomZlibStream
388
389
constructor TCustomZLibStream.Create(Strm: TStream);
390
begin
391
inherited Create;
392
FStrm := Strm;
393
FStrmPos := Strm.Position;
394
FZRec.zalloc := zlibAllocMem;
395
FZRec.zfree := zlibFreeMem;
396
end;
397
398
procedure TCustomZLibStream.Progress(Sender: TObject);
399
begin
400
if Assigned(FOnProgress) then FOnProgress(Sender);
401
end;
402
403
404
// TCompressionStream
405
406
constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
407
Dest: TStream);
408
const
409
Levels: array [TCompressionLevel] of ShortInt =
410
(Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
411
begin
412
inherited Create(Dest);
413
FZRec.next_out := FBuffer;
414
FZRec.avail_out := sizeof(FBuffer);
415
CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
416
end;
417
418
destructor TCompressionStream.Destroy;
419
begin
420
FZRec.next_in := nil;
421
FZRec.avail_in := 0;
422
try
423
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
424
while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
425
and (FZRec.avail_out = 0) do
426
begin
427
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
428
FZRec.next_out := FBuffer;
429
FZRec.avail_out := sizeof(FBuffer);
430
end;
431
if FZRec.avail_out < sizeof(FBuffer) then
432
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
433
finally
434
deflateEnd(FZRec);
435
end;
436
inherited Destroy;
437
end;
438
439
function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
440
begin
441
raise ECompressionError.CreateRes(@sInvalidStreamOp);
442
end;
443
444
function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
445
begin
446
FZRec.next_in := @Buffer;
447
FZRec.avail_in := Count;
448
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
449
while (FZRec.avail_in > 0) do
450
begin
451
CCheck(deflate(FZRec, 0));
452
if FZRec.avail_out = 0 then
453
begin
454
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
455
FZRec.next_out := FBuffer;
456
FZRec.avail_out := sizeof(FBuffer);
457
FStrmPos := FStrm.Position;
458
Progress(Self);
459
end;
460
end;
461
Result := Count;
462
end;
463
464
function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
465
begin
466
if (Offset = 0) and (Origin = soFromCurrent) then
467
Result := FZRec.total_in
468
else
469
raise ECompressionError.CreateRes(@sInvalidStreamOp);
470
end;
471
472
function TCompressionStream.GetCompressionRate: Single;
473
begin
474
if FZRec.total_in = 0 then
475
Result := 0
476
else
477
Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
478
end;
479
480
481
// TDecompressionStream
482
483
constructor TDecompressionStream.Create(Source: TStream);
484
begin
485
inherited Create(Source);
486
FZRec.next_in := FBuffer;
487
FZRec.avail_in := 0;
488
DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
489
end;
490
491
destructor TDecompressionStream.Destroy;
492
begin
493
FStrm.Seek(-FZRec.avail_in, 1);
494
inflateEnd(FZRec);
495
inherited Destroy;
496
end;
497
498
function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
499
begin
500
FZRec.next_out := @Buffer;
501
FZRec.avail_out := Count;
502
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
503
while (FZRec.avail_out > 0) do
504
begin
505
if FZRec.avail_in = 0 then
506
begin
507
FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
508
if FZRec.avail_in = 0 then
509
begin
510
Result := Count - FZRec.avail_out;
511
Exit;
512
end;
513
FZRec.next_in := FBuffer;
514
FStrmPos := FStrm.Position;
515
Progress(Self);
516
end;
517
CCheck(inflate(FZRec, 0));
518
end;
519
Result := Count;
520
end;
521
522
function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
523
begin
524
raise EDecompressionError.CreateRes(@sInvalidStreamOp);
525
end;
526
527
function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
528
var
529
I: Integer;
530
Buf: array [0..4095] of Char;
531
begin
532
if (Offset = 0) and (Origin = soFromBeginning) then
533
begin
534
DCheck(inflateReset(FZRec));
535
FZRec.next_in := FBuffer;
536
FZRec.avail_in := 0;
537
FStrm.Position := 0;
538
FStrmPos := 0;
539
end
540
else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
541
( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
542
begin
543
if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
544
if Offset > 0 then
545
begin
546
for I := 1 to Offset div sizeof(Buf) do
547
ReadBuffer(Buf, sizeof(Buf));
548
ReadBuffer(Buf, Offset mod sizeof(Buf));
549
end;
550
end
551
else
552
raise EDecompressionError.CreateRes(@sInvalidStreamOp);
553
Result := FZRec.total_out;
554
end;
555
556
557
end.
558

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button