third_party/zlib: Initial copy of zlib.
[sfrench/samba-autobuild/.git] / third_party / zlib / contrib / pascal / example.pas
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.