Fossil SCM

fossil-scm / compat / zlib / contrib / pascal / example.pas
Blame History Raw 600 lines
1
(* example.c -- usage example of the zlib compression library
2
* Copyright (C) 1995-2003 Jean-loup Gailly.
3
* For conditions of distribution and use, see copyright notice in zlib.h
4
*
5
* Pascal translation
6
* Copyright (C) 1998 by Jacques Nomssi Nzali.
7
* For conditions of distribution and use, see copyright notice in readme.txt
8
*
9
* Adaptation to the zlibpas interface
10
* Copyright (C) 2003 by Cosmin Truta.
11
* For conditions of distribution and use, see copyright notice in readme.txt
12
*)
13
14
program example;
15
16
{$DEFINE TEST_COMPRESS}
17
{DO NOT $DEFINE TEST_GZIO}
18
{$DEFINE TEST_DEFLATE}
19
{$DEFINE TEST_INFLATE}
20
{$DEFINE TEST_FLUSH}
21
{$DEFINE TEST_SYNC}
22
{$DEFINE TEST_DICT}
23
24
uses SysUtils, zlibpas;
25
26
const TESTFILE = 'foo.gz';
27
28
(* "hello world" would be more standard, but the repeated "hello"
29
* stresses the compression code better, sorry...
30
*)
31
const hello: PChar = 'hello, hello!';
32
33
const dictionary: PChar = 'hello';
34
35
var dictId: LongInt; (* Adler32 value of the dictionary *)
36
37
procedure CHECK_ERR(err: Integer; msg: String);
38
begin
39
if err <> Z_OK then
40
begin
41
WriteLn(msg, ' error: ', err);
42
Halt(1);
43
end;
44
end;
45
46
procedure EXIT_ERR(const msg: String);
47
begin
48
WriteLn('Error: ', msg);
49
Halt(1);
50
end;
51
52
(* ===========================================================================
53
* Test compress and uncompress
54
*)
55
{$IFDEF TEST_COMPRESS}
56
procedure test_compress(compr: Pointer; comprLen: LongInt;
57
uncompr: Pointer; uncomprLen: LongInt);
58
var err: Integer;
59
len: LongInt;
60
begin
61
len := StrLen(hello)+1;
62
63
err := compress(compr, comprLen, hello, len);
64
CHECK_ERR(err, 'compress');
65
66
StrCopy(PChar(uncompr), 'garbage');
67
68
err := uncompress(uncompr, uncomprLen, compr, comprLen);
69
CHECK_ERR(err, 'uncompress');
70
71
if StrComp(PChar(uncompr), hello) <> 0 then
72
EXIT_ERR('bad uncompress')
73
else
74
WriteLn('uncompress(): ', PChar(uncompr));
75
end;
76
{$ENDIF}
77
78
(* ===========================================================================
79
* Test read/write of .gz files
80
*)
81
{$IFDEF TEST_GZIO}
82
procedure test_gzio(const fname: PChar; (* compressed file name *)
83
uncompr: Pointer;
84
uncomprLen: LongInt);
85
var err: Integer;
86
len: Integer;
87
zfile: gzFile;
88
pos: LongInt;
89
begin
90
len := StrLen(hello)+1;
91
92
zfile := gzopen(fname, 'wb');
93
if zfile = NIL then
94
begin
95
WriteLn('gzopen error');
96
Halt(1);
97
end;
98
gzputc(zfile, 'h');
99
if gzputs(zfile, 'ello') <> 4 then
100
begin
101
WriteLn('gzputs err: ', gzerror(zfile, err));
102
Halt(1);
103
end;
104
{$IFDEF GZ_FORMAT_STRING}
105
if gzprintf(zfile, ', %s!', 'hello') <> 8 then
106
begin
107
WriteLn('gzprintf err: ', gzerror(zfile, err));
108
Halt(1);
109
end;
110
{$ELSE}
111
if gzputs(zfile, ', hello!') <> 8 then
112
begin
113
WriteLn('gzputs err: ', gzerror(zfile, err));
114
Halt(1);
115
end;
116
{$ENDIF}
117
gzseek(zfile, 1, SEEK_CUR); (* add one zero byte *)
118
gzclose(zfile);
119
120
zfile := gzopen(fname, 'rb');
121
if zfile = NIL then
122
begin
123
WriteLn('gzopen error');
124
Halt(1);
125
end;
126
127
StrCopy(PChar(uncompr), 'garbage');
128
129
if gzread(zfile, uncompr, uncomprLen) <> len then
130
begin
131
WriteLn('gzread err: ', gzerror(zfile, err));
132
Halt(1);
133
end;
134
if StrComp(PChar(uncompr), hello) <> 0 then
135
begin
136
WriteLn('bad gzread: ', PChar(uncompr));
137
Halt(1);
138
end
139
else
140
WriteLn('gzread(): ', PChar(uncompr));
141
142
pos := gzseek(zfile, -8, SEEK_CUR);
143
if (pos <> 6) or (gztell(zfile) <> pos) then
144
begin
145
WriteLn('gzseek error, pos=', pos, ', gztell=', gztell(zfile));
146
Halt(1);
147
end;
148
149
if gzgetc(zfile) <> ' ' then
150
begin
151
WriteLn('gzgetc error');
152
Halt(1);
153
end;
154
155
if gzungetc(' ', zfile) <> ' ' then
156
begin
157
WriteLn('gzungetc error');
158
Halt(1);
159
end;
160
161
gzgets(zfile, PChar(uncompr), uncomprLen);
162
uncomprLen := StrLen(PChar(uncompr));
163
if uncomprLen <> 7 then (* " hello!" *)
164
begin
165
WriteLn('gzgets err after gzseek: ', gzerror(zfile, err));
166
Halt(1);
167
end;
168
if StrComp(PChar(uncompr), hello + 6) <> 0 then
169
begin
170
WriteLn('bad gzgets after gzseek');
171
Halt(1);
172
end
173
else
174
WriteLn('gzgets() after gzseek: ', PChar(uncompr));
175
176
gzclose(zfile);
177
end;
178
{$ENDIF}
179
180
(* ===========================================================================
181
* Test deflate with small buffers
182
*)
183
{$IFDEF TEST_DEFLATE}
184
procedure test_deflate(compr: Pointer; comprLen: LongInt);
185
var c_stream: z_stream; (* compression stream *)
186
err: Integer;
187
len: LongInt;
188
begin
189
len := StrLen(hello)+1;
190
191
c_stream.zalloc := NIL;
192
c_stream.zfree := NIL;
193
c_stream.opaque := NIL;
194
195
err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
196
CHECK_ERR(err, 'deflateInit');
197
198
c_stream.next_in := hello;
199
c_stream.next_out := compr;
200
201
while (c_stream.total_in <> len) and
202
(c_stream.total_out < comprLen) do
203
begin
204
c_stream.avail_out := 1; { force small buffers }
205
c_stream.avail_in := 1;
206
err := deflate(c_stream, Z_NO_FLUSH);
207
CHECK_ERR(err, 'deflate');
208
end;
209
210
(* Finish the stream, still forcing small buffers: *)
211
while TRUE do
212
begin
213
c_stream.avail_out := 1;
214
err := deflate(c_stream, Z_FINISH);
215
if err = Z_STREAM_END then
216
break;
217
CHECK_ERR(err, 'deflate');
218
end;
219
220
err := deflateEnd(c_stream);
221
CHECK_ERR(err, 'deflateEnd');
222
end;
223
{$ENDIF}
224
225
(* ===========================================================================
226
* Test inflate with small buffers
227
*)
228
{$IFDEF TEST_INFLATE}
229
procedure test_inflate(compr: Pointer; comprLen : LongInt;
230
uncompr: Pointer; uncomprLen : LongInt);
231
var err: Integer;
232
d_stream: z_stream; (* decompression stream *)
233
begin
234
StrCopy(PChar(uncompr), 'garbage');
235
236
d_stream.zalloc := NIL;
237
d_stream.zfree := NIL;
238
d_stream.opaque := NIL;
239
240
d_stream.next_in := compr;
241
d_stream.avail_in := 0;
242
d_stream.next_out := uncompr;
243
244
err := inflateInit(d_stream);
245
CHECK_ERR(err, 'inflateInit');
246
247
while (d_stream.total_out < uncomprLen) and
248
(d_stream.total_in < comprLen) do
249
begin
250
d_stream.avail_out := 1; (* force small buffers *)
251
d_stream.avail_in := 1;
252
err := inflate(d_stream, Z_NO_FLUSH);
253
if err = Z_STREAM_END then
254
break;
255
CHECK_ERR(err, 'inflate');
256
end;
257
258
err := inflateEnd(d_stream);
259
CHECK_ERR(err, 'inflateEnd');
260
261
if StrComp(PChar(uncompr), hello) <> 0 then
262
EXIT_ERR('bad inflate')
263
else
264
WriteLn('inflate(): ', PChar(uncompr));
265
end;
266
{$ENDIF}
267
268
(* ===========================================================================
269
* Test deflate with large buffers and dynamic change of compression level
270
*)
271
{$IFDEF TEST_DEFLATE}
272
procedure test_large_deflate(compr: Pointer; comprLen: LongInt;
273
uncompr: Pointer; uncomprLen: LongInt);
274
var c_stream: z_stream; (* compression stream *)
275
err: Integer;
276
begin
277
c_stream.zalloc := NIL;
278
c_stream.zfree := NIL;
279
c_stream.opaque := NIL;
280
281
err := deflateInit(c_stream, Z_BEST_SPEED);
282
CHECK_ERR(err, 'deflateInit');
283
284
c_stream.next_out := compr;
285
c_stream.avail_out := Integer(comprLen);
286
287
(* At this point, uncompr is still mostly zeroes, so it should compress
288
* very well:
289
*)
290
c_stream.next_in := uncompr;
291
c_stream.avail_in := Integer(uncomprLen);
292
err := deflate(c_stream, Z_NO_FLUSH);
293
CHECK_ERR(err, 'deflate');
294
if c_stream.avail_in <> 0 then
295
EXIT_ERR('deflate not greedy');
296
297
(* Feed in already compressed data and switch to no compression: *)
298
deflateParams(c_stream, Z_NO_COMPRESSION, Z_DEFAULT_STRATEGY);
299
c_stream.next_in := compr;
300
c_stream.avail_in := Integer(comprLen div 2);
301
err := deflate(c_stream, Z_NO_FLUSH);
302
CHECK_ERR(err, 'deflate');
303
304
(* Switch back to compressing mode: *)
305
deflateParams(c_stream, Z_BEST_COMPRESSION, Z_FILTERED);
306
c_stream.next_in := uncompr;
307
c_stream.avail_in := Integer(uncomprLen);
308
err := deflate(c_stream, Z_NO_FLUSH);
309
CHECK_ERR(err, 'deflate');
310
311
err := deflate(c_stream, Z_FINISH);
312
if err <> Z_STREAM_END then
313
EXIT_ERR('deflate should report Z_STREAM_END');
314
315
err := deflateEnd(c_stream);
316
CHECK_ERR(err, 'deflateEnd');
317
end;
318
{$ENDIF}
319
320
(* ===========================================================================
321
* Test inflate with large buffers
322
*)
323
{$IFDEF TEST_INFLATE}
324
procedure test_large_inflate(compr: Pointer; comprLen: LongInt;
325
uncompr: Pointer; uncomprLen: LongInt);
326
var err: Integer;
327
d_stream: z_stream; (* decompression stream *)
328
begin
329
StrCopy(PChar(uncompr), 'garbage');
330
331
d_stream.zalloc := NIL;
332
d_stream.zfree := NIL;
333
d_stream.opaque := NIL;
334
335
d_stream.next_in := compr;
336
d_stream.avail_in := Integer(comprLen);
337
338
err := inflateInit(d_stream);
339
CHECK_ERR(err, 'inflateInit');
340
341
while TRUE do
342
begin
343
d_stream.next_out := uncompr; (* discard the output *)
344
d_stream.avail_out := Integer(uncomprLen);
345
err := inflate(d_stream, Z_NO_FLUSH);
346
if err = Z_STREAM_END then
347
break;
348
CHECK_ERR(err, 'large inflate');
349
end;
350
351
err := inflateEnd(d_stream);
352
CHECK_ERR(err, 'inflateEnd');
353
354
if d_stream.total_out <> 2 * uncomprLen + comprLen div 2 then
355
begin
356
WriteLn('bad large inflate: ', d_stream.total_out);
357
Halt(1);
358
end
359
else
360
WriteLn('large_inflate(): OK');
361
end;
362
{$ENDIF}
363
364
(* ===========================================================================
365
* Test deflate with full flush
366
*)
367
{$IFDEF TEST_FLUSH}
368
procedure test_flush(compr: Pointer; var comprLen : LongInt);
369
var c_stream: z_stream; (* compression stream *)
370
err: Integer;
371
len: Integer;
372
begin
373
len := StrLen(hello)+1;
374
375
c_stream.zalloc := NIL;
376
c_stream.zfree := NIL;
377
c_stream.opaque := NIL;
378
379
err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
380
CHECK_ERR(err, 'deflateInit');
381
382
c_stream.next_in := hello;
383
c_stream.next_out := compr;
384
c_stream.avail_in := 3;
385
c_stream.avail_out := Integer(comprLen);
386
err := deflate(c_stream, Z_FULL_FLUSH);
387
CHECK_ERR(err, 'deflate');
388
389
Inc(PByteArray(compr)^[3]); (* force an error in first compressed block *)
390
c_stream.avail_in := len - 3;
391
392
err := deflate(c_stream, Z_FINISH);
393
if err <> Z_STREAM_END then
394
CHECK_ERR(err, 'deflate');
395
396
err := deflateEnd(c_stream);
397
CHECK_ERR(err, 'deflateEnd');
398
399
comprLen := c_stream.total_out;
400
end;
401
{$ENDIF}
402
403
(* ===========================================================================
404
* Test inflateSync()
405
*)
406
{$IFDEF TEST_SYNC}
407
procedure test_sync(compr: Pointer; comprLen: LongInt;
408
uncompr: Pointer; uncomprLen : LongInt);
409
var err: Integer;
410
d_stream: z_stream; (* decompression stream *)
411
begin
412
StrCopy(PChar(uncompr), 'garbage');
413
414
d_stream.zalloc := NIL;
415
d_stream.zfree := NIL;
416
d_stream.opaque := NIL;
417
418
d_stream.next_in := compr;
419
d_stream.avail_in := 2; (* just read the zlib header *)
420
421
err := inflateInit(d_stream);
422
CHECK_ERR(err, 'inflateInit');
423
424
d_stream.next_out := uncompr;
425
d_stream.avail_out := Integer(uncomprLen);
426
427
inflate(d_stream, Z_NO_FLUSH);
428
CHECK_ERR(err, 'inflate');
429
430
d_stream.avail_in := Integer(comprLen-2); (* read all compressed data *)
431
err := inflateSync(d_stream); (* but skip the damaged part *)
432
CHECK_ERR(err, 'inflateSync');
433
434
err := inflate(d_stream, Z_FINISH);
435
if err <> Z_DATA_ERROR then
436
EXIT_ERR('inflate should report DATA_ERROR');
437
(* Because of incorrect adler32 *)
438
439
err := inflateEnd(d_stream);
440
CHECK_ERR(err, 'inflateEnd');
441
442
WriteLn('after inflateSync(): hel', PChar(uncompr));
443
end;
444
{$ENDIF}
445
446
(* ===========================================================================
447
* Test deflate with preset dictionary
448
*)
449
{$IFDEF TEST_DICT}
450
procedure test_dict_deflate(compr: Pointer; comprLen: LongInt);
451
var c_stream: z_stream; (* compression stream *)
452
err: Integer;
453
begin
454
c_stream.zalloc := NIL;
455
c_stream.zfree := NIL;
456
c_stream.opaque := NIL;
457
458
err := deflateInit(c_stream, Z_BEST_COMPRESSION);
459
CHECK_ERR(err, 'deflateInit');
460
461
err := deflateSetDictionary(c_stream, dictionary, StrLen(dictionary));
462
CHECK_ERR(err, 'deflateSetDictionary');
463
464
dictId := c_stream.adler;
465
c_stream.next_out := compr;
466
c_stream.avail_out := Integer(comprLen);
467
468
c_stream.next_in := hello;
469
c_stream.avail_in := StrLen(hello)+1;
470
471
err := deflate(c_stream, Z_FINISH);
472
if err <> Z_STREAM_END then
473
EXIT_ERR('deflate should report Z_STREAM_END');
474
475
err := deflateEnd(c_stream);
476
CHECK_ERR(err, 'deflateEnd');
477
end;
478
{$ENDIF}
479
480
(* ===========================================================================
481
* Test inflate with a preset dictionary
482
*)
483
{$IFDEF TEST_DICT}
484
procedure test_dict_inflate(compr: Pointer; comprLen: LongInt;
485
uncompr: Pointer; uncomprLen: LongInt);
486
var err: Integer;
487
d_stream: z_stream; (* decompression stream *)
488
begin
489
StrCopy(PChar(uncompr), 'garbage');
490
491
d_stream.zalloc := NIL;
492
d_stream.zfree := NIL;
493
d_stream.opaque := NIL;
494
495
d_stream.next_in := compr;
496
d_stream.avail_in := Integer(comprLen);
497
498
err := inflateInit(d_stream);
499
CHECK_ERR(err, 'inflateInit');
500
501
d_stream.next_out := uncompr;
502
d_stream.avail_out := Integer(uncomprLen);
503
504
while TRUE do
505
begin
506
err := inflate(d_stream, Z_NO_FLUSH);
507
if err = Z_STREAM_END then
508
break;
509
if err = Z_NEED_DICT then
510
begin
511
if d_stream.adler <> dictId then
512
EXIT_ERR('unexpected dictionary');
513
err := inflateSetDictionary(d_stream, dictionary, StrLen(dictionary));
514
end;
515
CHECK_ERR(err, 'inflate with dict');
516
end;
517
518
err := inflateEnd(d_stream);
519
CHECK_ERR(err, 'inflateEnd');
520
521
if StrComp(PChar(uncompr), hello) <> 0 then
522
EXIT_ERR('bad inflate with dict')
523
else
524
WriteLn('inflate with dictionary: ', PChar(uncompr));
525
end;
526
{$ENDIF}
527
528
var compr, uncompr: Pointer;
529
comprLen, uncomprLen: LongInt;
530
531
begin
532
if zlibVersion^ <> ZLIB_VERSION[1] then
533
EXIT_ERR('Incompatible zlib version');
534
535
WriteLn('zlib version: ', zlibVersion);
536
WriteLn('zlib compile flags: ', Format('0x%x', [zlibCompileFlags]));
537
538
comprLen := 10000 * SizeOf(Integer); (* don't overflow on MSDOS *)
539
uncomprLen := comprLen;
540
GetMem(compr, comprLen);
541
GetMem(uncompr, uncomprLen);
542
if (compr = NIL) or (uncompr = NIL) then
543
EXIT_ERR('Out of memory');
544
(* compr and uncompr are cleared to avoid reading uninitialized
545
* data and to ensure that uncompr compresses well.
546
*)
547
FillChar(compr^, comprLen, 0);
548
FillChar(uncompr^, uncomprLen, 0);
549
550
{$IFDEF TEST_COMPRESS}
551
WriteLn('** Testing compress');
552
test_compress(compr, comprLen, uncompr, uncomprLen);
553
{$ENDIF}
554
555
{$IFDEF TEST_GZIO}
556
WriteLn('** Testing gzio');
557
if ParamCount >= 1 then
558
test_gzio(ParamStr(1), uncompr, uncomprLen)
559
else
560
test_gzio(TESTFILE, uncompr, uncomprLen);
561
{$ENDIF}
562
563
{$IFDEF TEST_DEFLATE}
564
WriteLn('** Testing deflate with small buffers');
565
test_deflate(compr, comprLen);
566
{$ENDIF}
567
{$IFDEF TEST_INFLATE}
568
WriteLn('** Testing inflate with small buffers');
569
test_inflate(compr, comprLen, uncompr, uncomprLen);
570
{$ENDIF}
571
572
{$IFDEF TEST_DEFLATE}
573
WriteLn('** Testing deflate with large buffers');
574
test_large_deflate(compr, comprLen, uncompr, uncomprLen);
575
{$ENDIF}
576
{$IFDEF TEST_INFLATE}
577
WriteLn('** Testing inflate with large buffers');
578
test_large_inflate(compr, comprLen, uncompr, uncomprLen);
579
{$ENDIF}
580
581
{$IFDEF TEST_FLUSH}
582
WriteLn('** Testing deflate with full flush');
583
test_flush(compr, comprLen);
584
{$ENDIF}
585
{$IFDEF TEST_SYNC}
586
WriteLn('** Testing inflateSync');
587
test_sync(compr, comprLen, uncompr, uncomprLen);
588
{$ENDIF}
589
comprLen := uncomprLen;
590
591
{$IFDEF TEST_DICT}
592
WriteLn('** Testing deflate and inflate with preset dictionary');
593
test_dict_deflate(compr, comprLen);
594
test_dict_inflate(compr, comprLen, uncompr, uncomprLen);
595
{$ENDIF}
596
597
FreeMem(compr, comprLen);
598
FreeMem(uncompr, uncomprLen);
599
end.
600

Keyboard Shortcuts

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