common/dist/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.