Quelle example.pas Sprache: Delphi

(* example.c -- usage example of the zlib compression library
* Copyright (C) 1995-2003 Jean-loup Gailly.
* For conditions of distribution and use, see copyright notice in zlib.h
*
* Pascal translation
* Copyright (C) 1998 by Jacques Nomssi Nzali.
* For conditions of distribution and use, see copyright notice in readme.txt
*
* Adaptation to the zlibpas interface
* Copyright (C) 2003 by Cosmin Truta.
* For conditions of distribution and use, see copyright notice in readme.txt
*)

program example;

{$DEFINE TEST_COMPRESS}
{DO NOT $DEFINE TEST_GZIO}
{$DEFINE TEST_DEFLATE}
{$DEFINE TEST_INFLATE}
{$DEFINE TEST_FLUSH}
{$DEFINE TEST_SYNC}
{$DEFINE TEST_DICT}

uses SysUtils, zlibpas;

const TESTFILE = 'foo.gz';

(* "hello world" would be more standard, but the repeated "hello"
* stresses the compression code better, sorry...
*)
const hello: PChar = 'hello, hello!';

const dictionary: PChar = 'hello';

var dictId: LongInt; (* Adler32 value of the dictionary *)

procedure CHECK_ERR(err: Integer; msg: String);
begin
  if err <> Z_OK then
  begin
    WriteLn(msg, ' error: ', err);
    Halt(1);
  end;
end;

procedure EXIT_ERR(const msg: String);
begin
  WriteLn('Error: ', msg);
  Halt(1);
end;

(* ===========================================================================
* Test compress and uncompress
*)
{$IFDEF TEST_COMPRESS}
procedure test_compress(compr: Pointer; comprLen: LongInt;
                        uncompr: Pointer; uncomprLen: LongInt);
var err: Integer;
    len: LongInt;
begin
  len := StrLen(hello)+1;

  err := compress(compr, comprLen, hello, len);
  CHECK_ERR(err, 'compress');

  StrCopy(PChar(uncompr), 'garbage');

  err := uncompress(uncompr, uncomprLen, compr, comprLen);
  CHECK_ERR(err, 'uncompress');

  if StrComp(PChar(uncompr), hello) <> 0 then
    EXIT_ERR('bad uncompress')
  else
    WriteLn('uncompress(): ', PChar(uncompr));
end;
{$ENDIF}

(* ===========================================================================
* Test read/write of .gz files
*)
{$IFDEF TEST_GZIO}
procedure test_gzio(const fname: PChar; (* compressed file name *)
                    uncompr: Pointer;
                    uncomprLen: LongInt);
var err: Integer;
    len: Integer;
    zfile: gzFile;
    pos: LongInt;
begin
  len := StrLen(hello)+1;

  zfile := gzopen(fname, 'wb');
  if zfile = NIL then
  begin
    WriteLn('gzopen error');
    Halt(1);
  end;
  gzputc(zfile, 'h');
  if gzputs(zfile, 'ello') <> 4 then
  begin
    WriteLn('gzputs err: ', gzerror(zfile, err));
    Halt(1);
  end;
  {$IFDEF GZ_FORMAT_STRING}
  if gzprintf(zfile, ', %s!', 'hello') <> 8 then
  begin
    WriteLn('gzprintf err: ', gzerror(zfile, err));
    Halt(1);
  end;
  {$ELSE}
  if gzputs(zfile, ', hello!') <> 8 then
  begin
    WriteLn('gzputs err: ', gzerror(zfile, err));
    Halt(1);
  end;
  {$ENDIF}
  gzseek(zfile, 1, SEEK_CUR); (* add one zero byte *)
  gzclose(zfile);

  zfile := gzopen(fname, 'rb');
  if zfile = NIL then
  begin
    WriteLn('gzopen error');
    Halt(1);
  end;

  StrCopy(PChar(uncompr), 'garbage');

  if gzread(zfile, uncompr, uncomprLen) <> len then
  begin
    WriteLn('gzread err: ', gzerror(zfile, err));
    Halt(1);
  end;
  if StrComp(PChar(uncompr), hello) <> 0 then
  begin
    WriteLn('bad gzread: ', PChar(uncompr));
    Halt(1);
  end
  else
    WriteLn('gzread(): ', PChar(uncompr));

  pos := gzseek(zfile, -8, SEEK_CUR);
  if (pos <> 6) or (gztell(zfile) <> pos) then
  begin
    WriteLn('gzseek error, pos=', pos, ', gztell=', gztell(zfile));
    Halt(1);
  end;

  if gzgetc(zfile) <> ' ' then
  begin
    WriteLn('gzgetc error');
    Halt(1);
  end;

  if gzungetc(' ', zfile) <> ' ' then
  begin
    WriteLn('gzungetc error');
    Halt(1);
  end;

  gzgets(zfile, PChar(uncompr), uncomprLen);
  uncomprLen := StrLen(PChar(uncompr));
  if uncomprLen <> 7 then (* " hello!" *)
  begin
    WriteLn('gzgets err after gzseek: ', gzerror(zfile, err));
    Halt(1);
  end;
  if StrComp(PChar(uncompr), hello + 6) <> 0 then
  begin
    WriteLn('bad gzgets after gzseek');
    Halt(1);
  end
  else
    WriteLn('gzgets() after gzseek: ', PChar(uncompr));

  gzclose(zfile);
end;
{$ENDIF}

(* ===========================================================================
* Test deflate with small buffers
*)
{$IFDEF TEST_DEFLATE}
procedure test_deflate(compr: Pointer; comprLen: LongInt);
var c_stream: z_stream; (* compression stream *)
    err: Integer;
    len: LongInt;
begin
  len := StrLen(hello)+1;

  c_stream.zalloc := NIL;
  c_stream.zfree := NIL;
  c_stream.opaque := NIL;

  err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
  CHECK_ERR(err, 'deflateInit');

  c_stream.next_in := hello;
  c_stream.next_out := compr;

  while (c_stream.total_in <> len) and
        (c_stream.total_out < comprLen) do
  begin
    c_stream.avail_out := 1; { force small buffers }
    c_stream.avail_in := 1;
    err := deflate(c_stream, Z_NO_FLUSH);
    CHECK_ERR(err, 'deflate');
  end;

  (* Finish the stream, still forcing small buffers: *)
  while TRUE do
  begin
    c_stream.avail_out := 1;
    err := deflate(c_stream, Z_FINISH);
    if err = Z_STREAM_END then
      break;
    CHECK_ERR(err, 'deflate');
  end;

  err := deflateEnd(c_stream);
  CHECK_ERR(err, 'deflateEnd');
end;
{$ENDIF}

(* ===========================================================================
* Test inflate with small buffers
*)
{$IFDEF TEST_INFLATE}
procedure test_inflate(compr: Pointer; comprLen : LongInt;
                       uncompr: Pointer; uncomprLen : LongInt);
var err: Integer;
    d_stream: z_stream; (* decompression stream *)
begin
  StrCopy(PChar(uncompr), 'garbage');

  d_stream.zalloc := NIL;
  d_stream.zfree := NIL;
  d_stream.opaque := NIL;

  d_stream.next_in := compr;
  d_stream.avail_in := 0;
  d_stream.next_out := uncompr;

  err := inflateInit(d_stream);
  CHECK_ERR(err, 'inflateInit');

  while (d_stream.total_out < uncomprLen) and
        (d_stream.total_in < comprLen) do
  begin
    d_stream.avail_out := 1; (* force small buffers *)
    d_stream.avail_in := 1;
    err := inflate(d_stream, Z_NO_FLUSH);
    if err = Z_STREAM_END then
      break;
    CHECK_ERR(err, 'inflate');
  end;

  err := inflateEnd(d_stream);
  CHECK_ERR(err, 'inflateEnd');

  if StrComp(PChar(uncompr), hello) <> 0 then
    EXIT_ERR('bad inflate')
  else
    WriteLn('inflate(): ', PChar(uncompr));
end;
{$ENDIF}

(* ===========================================================================
* Test deflate with large buffers and dynamic change of compression level
*)
{$IFDEF TEST_DEFLATE}
procedure test_large_deflate(compr: Pointer; comprLen: LongInt;
                             uncompr: Pointer; uncomprLen: LongInt);
var c_stream: z_stream; (* compression stream *)
    err: Integer;
begin
  c_stream.zalloc := NIL;
  c_stream.zfree := NIL;
  c_stream.opaque := NIL;

  err := deflateInit(c_stream, Z_BEST_SPEED);
  CHECK_ERR(err, 'deflateInit');

  c_stream.next_out := compr;
  c_stream.avail_out := Integer(comprLen);

  (* At this point, uncompr is still mostly zeroes, so it should compress
   * very well:
   *)
  c_stream.next_in := uncompr;
  c_stream.avail_in := Integer(uncomprLen);
  err := deflate(c_stream, Z_NO_FLUSH);
  CHECK_ERR(err, 'deflate');
  if c_stream.avail_in <> 0 then
    EXIT_ERR('deflate not greedy');

  (* Feed in already compressed data and switch to no compression: *)
  deflateParams(c_stream, Z_NO_COMPRESSION, Z_DEFAULT_STRATEGY);
  c_stream.next_in := compr;
  c_stream.avail_in := Integer(comprLen div 2);
  err := deflate(c_stream, Z_NO_FLUSH);
  CHECK_ERR(err, 'deflate');

  (* Switch back to compressing mode: *)
  deflateParams(c_stream, Z_BEST_COMPRESSION, Z_FILTERED);
  c_stream.next_in := uncompr;
  c_stream.avail_in := Integer(uncomprLen);
  err := deflate(c_stream, Z_NO_FLUSH);
  CHECK_ERR(err, 'deflate');

  err := deflate(c_stream, Z_FINISH);
  if err <> Z_STREAM_END then
    EXIT_ERR('deflate should report Z_STREAM_END');

  err := deflateEnd(c_stream);
  CHECK_ERR(err, 'deflateEnd');
end;
{$ENDIF}

(* ===========================================================================
* Test inflate with large buffers
*)
{$IFDEF TEST_INFLATE}
procedure test_large_inflate(compr: Pointer; comprLen: LongInt;
                             uncompr: Pointer; uncomprLen: LongInt);
var err: Integer;
    d_stream: z_stream; (* decompression stream *)
begin
  StrCopy(PChar(uncompr), 'garbage');

  d_stream.zalloc := NIL;
  d_stream.zfree := NIL;
  d_stream.opaque := NIL;

  d_stream.next_in := compr;
  d_stream.avail_in := Integer(comprLen);

  err := inflateInit(d_stream);
  CHECK_ERR(err, 'inflateInit');

  while TRUE do
  begin
    d_stream.next_out := uncompr;            (* discard the output *)
    d_stream.avail_out := Integer(uncomprLen);
    err := inflate(d_stream, Z_NO_FLUSH);
    if err = Z_STREAM_END then
      break;
    CHECK_ERR(err, 'large inflate');
  end;

  err := inflateEnd(d_stream);
  CHECK_ERR(err, 'inflateEnd');

  if d_stream.total_out <> 2 * uncomprLen + comprLen div 2 then
  begin
    WriteLn('bad large inflate: ', d_stream.total_out);
    Halt(1);
  end
  else
    WriteLn('large_inflate(): OK');
end;
{$ENDIF}

(* ===========================================================================
* Test deflate with full flush
*)
{$IFDEF TEST_FLUSH}
procedure test_flush(compr: Pointer; var comprLen : LongInt);
var c_stream: z_stream; (* compression stream *)
    err: Integer;
    len: Integer;
begin
  len := StrLen(hello)+1;

  c_stream.zalloc := NIL;
  c_stream.zfree := NIL;
  c_stream.opaque := NIL;

  err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
  CHECK_ERR(err, 'deflateInit');

  c_stream.next_in := hello;
  c_stream.next_out := compr;
  c_stream.avail_in := 3;
  c_stream.avail_out := Integer(comprLen);
  err := deflate(c_stream, Z_FULL_FLUSH);
  CHECK_ERR(err, 'deflate');

  Inc(PByteArray(compr)^[3]); (* force an error in first compressed block *)
  c_stream.avail_in := len - 3;

  err := deflate(c_stream, Z_FINISH);
  if err <> Z_STREAM_END then
    CHECK_ERR(err, 'deflate');

  err := deflateEnd(c_stream);
  CHECK_ERR(err, 'deflateEnd');

  comprLen := c_stream.total_out;
end;
{$ENDIF}

(* ===========================================================================
* Test inflateSync()
*)
{$IFDEF TEST_SYNC}
procedure test_sync(compr: Pointer; comprLen: LongInt;
                    uncompr: Pointer; uncomprLen : LongInt);
var err: Integer;
    d_stream: z_stream; (* decompression stream *)
begin
  StrCopy(PChar(uncompr), 'garbage');

  d_stream.zalloc := NIL;
  d_stream.zfree := NIL;
  d_stream.opaque := NIL;

  d_stream.next_in := compr;
  d_stream.avail_in := 2; (* just read the zlib header *)

  err := inflateInit(d_stream);
  CHECK_ERR(err, 'inflateInit');

  d_stream.next_out := uncompr;
  d_stream.avail_out := Integer(uncomprLen);

  inflate(d_stream, Z_NO_FLUSH);
  CHECK_ERR(err, 'inflate');

  d_stream.avail_in := Integer(comprLen-2);   (* read all compressed data *)
  err := inflateSync(d_stream);               (* but skip the damaged part *)
  CHECK_ERR(err, 'inflateSync');

  err := inflate(d_stream, Z_FINISH);
  if err <> Z_DATA_ERROR then
    EXIT_ERR('inflate should report DATA_ERROR');
    (* Because of incorrect adler32 *)

  err := inflateEnd(d_stream);
  CHECK_ERR(err, 'inflateEnd');

  WriteLn('after inflateSync(): hel', PChar(uncompr));
end;
{$ENDIF}

(* ===========================================================================
* Test deflate with preset dictionary
*)
{$IFDEF TEST_DICT}
procedure test_dict_deflate(compr: Pointer; comprLen: LongInt);
var c_stream: z_stream; (* compression stream *)
    err: Integer;
begin
  c_stream.zalloc := NIL;
  c_stream.zfree := NIL;
  c_stream.opaque := NIL;

  err := deflateInit(c_stream, Z_BEST_COMPRESSION);
  CHECK_ERR(err, 'deflateInit');

  err := deflateSetDictionary(c_stream, dictionary, StrLen(dictionary));
  CHECK_ERR(err, 'deflateSetDictionary');

  dictId := c_stream.adler;
  c_stream.next_out := compr;
  c_stream.avail_out := Integer(comprLen);

  c_stream.next_in := hello;
  c_stream.avail_in := StrLen(hello)+1;

  err := deflate(c_stream, Z_FINISH);
  if err <> Z_STREAM_END then
    EXIT_ERR('deflate should report Z_STREAM_END');

  err := deflateEnd(c_stream);
  CHECK_ERR(err, 'deflateEnd');
end;
{$ENDIF}

(* ===========================================================================
* Test inflate with a preset dictionary
*)
{$IFDEF TEST_DICT}
procedure test_dict_inflate(compr: Pointer; comprLen: LongInt;
                            uncompr: Pointer; uncomprLen: LongInt);
var err: Integer;
    d_stream: z_stream; (* decompression stream *)
begin
  StrCopy(PChar(uncompr), 'garbage');

  d_stream.zalloc := NIL;
  d_stream.zfree := NIL;
  d_stream.opaque := NIL;

  d_stream.next_in := compr;
  d_stream.avail_in := Integer(comprLen);

  err := inflateInit(d_stream);
  CHECK_ERR(err, 'inflateInit');

  d_stream.next_out := uncompr;
  d_stream.avail_out := Integer(uncomprLen);

  while TRUE do
  begin
    err := inflate(d_stream, Z_NO_FLUSH);
    if err = Z_STREAM_END then
      break;
    if err = Z_NEED_DICT then
    begin
      if d_stream.adler <> dictId then
        EXIT_ERR('unexpected dictionary');
      err := inflateSetDictionary(d_stream, dictionary, StrLen(dictionary));
    end;
    CHECK_ERR(err, 'inflate with dict');
  end;

  err := inflateEnd(d_stream);
  CHECK_ERR(err, 'inflateEnd');

  if StrComp(PChar(uncompr), hello) <> 0 then
    EXIT_ERR('bad inflate with dict')
  else
    WriteLn('inflate with dictionary: ', PChar(uncompr));
end;
{$ENDIF}

var compr, uncompr: Pointer;
    comprLen, uncomprLen: LongInt;

begin
  if zlibVersion^ <> ZLIB_VERSION[1] then
    EXIT_ERR('Incompatible zlib version');

  WriteLn('zlib version: ', zlibVersion);
  WriteLn('zlib compile flags: ', Format('0x%x', [zlibCompileFlags]));

  comprLen := 10000 * SizeOf(Integer); (* don't overflow on MSDOS *)
  uncomprLen := comprLen;
  GetMem(compr, comprLen);
  GetMem(uncompr, uncomprLen);
  if (compr = NIL) or (uncompr = NIL) then
    EXIT_ERR('Out of memory');
  (* compr and uncompr are cleared to avoid reading uninitialized
   * data and to ensure that uncompr compresses well.
   *)
  FillChar(compr^, comprLen, 0);
  FillChar(uncompr^, uncomprLen, 0);

  {$IFDEF TEST_COMPRESS}
  WriteLn('** Testing compress');
  test_compress(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}

  {$IFDEF TEST_GZIO}
  WriteLn('** Testing gzio');
  if ParamCount >= 1 then
    test_gzio(ParamStr(1), uncompr, uncomprLen)
  else
    test_gzio(TESTFILE, uncompr, uncomprLen);
  {$ENDIF}

  {$IFDEF TEST_DEFLATE}
  WriteLn('** Testing deflate with small buffers');
  test_deflate(compr, comprLen);
  {$ENDIF}
  {$IFDEF TEST_INFLATE}
  WriteLn('** Testing inflate with small buffers');
  test_inflate(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}

  {$IFDEF TEST_DEFLATE}
  WriteLn('** Testing deflate with large buffers');
  test_large_deflate(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}
  {$IFDEF TEST_INFLATE}
  WriteLn('** Testing inflate with large buffers');
  test_large_inflate(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}

  {$IFDEF TEST_FLUSH}
  WriteLn('** Testing deflate with full flush');
  test_flush(compr, comprLen);
  {$ENDIF}
  {$IFDEF TEST_SYNC}
  WriteLn('** Testing inflateSync');
  test_sync(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}
  comprLen := uncomprLen;

  {$IFDEF TEST_DICT}
  WriteLn('** Testing deflate and inflate with preset dictionary');
  test_dict_deflate(compr, comprLen);
  test_dict_inflate(compr, comprLen, uncompr, uncomprLen);
  {$ENDIF}

  FreeMem(compr, comprLen);
  FreeMem(uncompr, uncomprLen);
end.

quality95%

¤ Dauer der Verarbeitung: 0.21 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.