← Back to branch summary

~ubuntu-branches/ubuntu/feisty/perl-tk/feisty

« back to all changes in this revision

Viewing changes to PNG/zlib/contrib/delphi2/zlib.pas

  • Committer: Bazaar Package Importer
  • Author(s): Michael C. Schultheiss
  • Date: 2006-10-01 15:14:26 UTC
  • mfrom: (3.1.2 edgy)
  • Revision ID: james.westby@ubuntu.com-20061001151426-8od1x69hl9a29h04
Tags: 1:804.027-7
http://bugs.debian.org/390382
* Urgency high due to RC bug:
  + debian/rules: Use $(CURDIR) rather than $(PWD) in prefix so files 
    are installed correctly on architectures using sudo rather than 
    fakeroot.   (Thanks to Niko Tyni. Closes: #390382)

Show diffs side-by-side

added added

removed removed

Lines of Context:
PNG/zlib/contrib/delphi2/zlib.pas
 
1
{*******************************************************}
 
2
{                                                       }
 
3
{       Delphi Supplemental Components                  }
 
4
{       ZLIB Data Compression Interface Unit            }
 
5
{                                                       }
 
6
{       Copyright (c) 1997 Borland International        }
 
7
{                                                       }
 
8
{*******************************************************}
 
9
 
 
10
{ Modified for zlib 1.1.3 by Davide Moretti <dave@rimini.com }
 
11
 
 
12
unit zlib;
 
13
 
 
14
interface
 
15
 
 
16
uses Sysutils, Classes;
 
17
 
 
18
type
 
19
  TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
 
20
  TFree = procedure (AppData, Block: Pointer);
 
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: Integer;    // 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: Integer;   // 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: Integer;       // adler32 value of the uncompressed data
 
41
    reserved: Integer;    // 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
const
 
147
  zlib_version = '1.1.3';
 
148
 
 
149
type
 
150
  EZlibError = class(Exception);
 
151
  ECompressionError = class(EZlibError);
 
152
  EDecompressionError = class(EZlibError);
 
153
 
 
154
function adler32(adler: Integer; buf: PChar; len: Integer): Integer;
 
155
 
 
156
implementation
 
157
 
 
158
const
 
159
  Z_NO_FLUSH      = 0;
 
160
  Z_PARTIAL_FLUSH = 1;
 
161
  Z_SYNC_FLUSH    = 2;
 
162
  Z_FULL_FLUSH    = 3;
 
163
  Z_FINISH        = 4;
 
164
 
 
165
  Z_OK            = 0;
 
166
  Z_STREAM_END    = 1;
 
167
  Z_NEED_DICT     = 2;
 
168
  Z_ERRNO         = (-1);
 
169
  Z_STREAM_ERROR  = (-2);
 
170
  Z_DATA_ERROR    = (-3);
 
171
  Z_MEM_ERROR     = (-4);
 
172
  Z_BUF_ERROR     = (-5);
 
173
  Z_VERSION_ERROR = (-6);
 
174
 
 
175
  Z_NO_COMPRESSION       =   0;
 
176
  Z_BEST_SPEED           =   1;
 
177
  Z_BEST_COMPRESSION     =   9;
 
178
  Z_DEFAULT_COMPRESSION  = (-1);
 
179
 
 
180
  Z_FILTERED            = 1;
 
181
  Z_HUFFMAN_ONLY        = 2;
 
182
  Z_DEFAULT_STRATEGY    = 0;
 
183
 
 
184
  Z_BINARY   = 0;
 
185
  Z_ASCII    = 1;
 
186
  Z_UNKNOWN  = 2;
 
187
 
 
188
  Z_DEFLATED = 8;
 
189
 
 
190
  _z_errmsg: array[0..9] of PChar = (
 
191
    'need dictionary',      // Z_NEED_DICT      (2)
 
192
    'stream end',           // Z_STREAM_END     (1)
 
193
    '',                     // Z_OK             (0)
 
194
    'file error',           // Z_ERRNO          (-1)
 
195
    'stream error',         // Z_STREAM_ERROR   (-2)
 
196
    'data error',           // Z_DATA_ERROR     (-3)
 
197
    'insufficient memory',  // Z_MEM_ERROR      (-4)
 
198
    'buffer error',         // Z_BUF_ERROR      (-5)
 
199
    'incompatible version', // Z_VERSION_ERROR  (-6)
 
200
    ''
 
201
  );
 
202
 
 
203
{$L deflate.obj}
 
204
{$L inflate.obj}
 
205
{$L inftrees.obj}
 
206
{$L trees.obj}
 
207
{$L adler32.obj}
 
208
{$L infblock.obj}
 
209
{$L infcodes.obj}
 
210
{$L infutil.obj}
 
211
{$L inffast.obj}
 
212
 
 
213
procedure _tr_init; external;
 
214
procedure _tr_tally; external;
 
215
procedure _tr_flush_block; external;
 
216
procedure _tr_align; external;
 
217
procedure _tr_stored_block; external;
 
218
function adler32; external;
 
219
procedure inflate_blocks_new; external;
 
220
procedure inflate_blocks; external;
 
221
procedure inflate_blocks_reset; external;
 
222
procedure inflate_blocks_free; external;
 
223
procedure inflate_set_dictionary; external;
 
224
procedure inflate_trees_bits; external;
 
225
procedure inflate_trees_dynamic; external;
 
226
procedure inflate_trees_fixed; external;
 
227
procedure inflate_codes_new; external;
 
228
procedure inflate_codes; external;
 
229
procedure inflate_codes_free; external;
 
230
procedure _inflate_mask; external;
 
231
procedure inflate_flush; external;
 
232
procedure inflate_fast; external;
 
233
 
 
234
procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
 
235
begin
 
236
  FillChar(P^, count, B);
 
237
end;
 
238
 
 
239
procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
 
240
begin
 
241
  Move(source^, dest^, count);
 
242
end;
 
243
 
 
244
 
 
245
 
 
246
// deflate compresses data
 
247
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
 
248
  recsize: Integer): Integer; external;
 
249
function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
 
250
function deflateEnd(var strm: TZStreamRec): Integer; external;
 
251
 
 
252
// inflate decompresses data
 
253
function inflateInit_(var strm: TZStreamRec; version: PChar;
 
254
  recsize: Integer): Integer; external;
 
255
function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
 
256
function inflateEnd(var strm: TZStreamRec): Integer; external;
 
257
function inflateReset(var strm: TZStreamRec): Integer; external;
 
258
 
 
259
 
 
260
function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer;
 
261
begin
 
262
  GetMem(Result, Items*Size);
 
263
end;
 
264
 
 
265
procedure zcfree(AppData, Block: Pointer);
 
266
begin
 
267
  FreeMem(Block);
 
268
end;
 
269
 
 
270
function zlibCheck(code: Integer): Integer;
 
271
begin
 
272
  Result := code;
 
273
  if code < 0 then
 
274
    raise EZlibError.Create('error');    //!!
 
275
end;
 
276
 
 
277
function CCheck(code: Integer): Integer;
 
278
begin
 
279
  Result := code;
 
280
  if code < 0 then
 
281
    raise ECompressionError.Create('error'); //!!
 
282
end;
 
283
 
 
284
function DCheck(code: Integer): Integer;
 
285
begin
 
286
  Result := code;
 
287
  if code < 0 then
 
288
    raise EDecompressionError.Create('error');  //!!
 
289
end;
 
290
 
 
291
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
 
292
                      out OutBuf: Pointer; out OutBytes: Integer);
 
293
var
 
294
  strm: TZStreamRec;
 
295
  P: Pointer;
 
296
begin
 
297
  FillChar(strm, sizeof(strm), 0);
 
298
  OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
 
299
  GetMem(OutBuf, OutBytes);
 
300
  try
 
301
    strm.next_in := InBuf;
 
302
    strm.avail_in := InBytes;
 
303
    strm.next_out := OutBuf;
 
304
    strm.avail_out := OutBytes;
 
305
    CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
 
306
    try
 
307
      while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
 
308
      begin
 
309
        P := OutBuf;
 
310
        Inc(OutBytes, 256);
 
311
        ReallocMem(OutBuf, OutBytes);
 
312
        strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 
313
        strm.avail_out := 256;
 
314
      end;
 
315
    finally
 
316
      CCheck(deflateEnd(strm));
 
317
    end;
 
318
    ReallocMem(OutBuf, strm.total_out);
 
319
    OutBytes := strm.total_out;
 
320
  except
 
321
    FreeMem(OutBuf);
 
322
    raise
 
323
  end;
 
324
end;
 
325
 
 
326
 
 
327
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 
328
  OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
 
329
var
 
330
  strm: TZStreamRec;
 
331
  P: Pointer;
 
332
  BufInc: Integer;
 
333
begin
 
334
  FillChar(strm, sizeof(strm), 0);
 
335
  BufInc := (InBytes + 255) and not 255;
 
336
  if OutEstimate = 0 then
 
337
    OutBytes := BufInc
 
338
  else
 
339
    OutBytes := OutEstimate;
 
340
  GetMem(OutBuf, OutBytes);
 
341
  try
 
342
    strm.next_in := InBuf;
 
343
    strm.avail_in := InBytes;
 
344
    strm.next_out := OutBuf;
 
345
    strm.avail_out := OutBytes;
 
346
    DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
 
347
    try
 
348
      while DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do
 
349
      begin
 
350
        P := OutBuf;
 
351
        Inc(OutBytes, BufInc);
 
352
        ReallocMem(OutBuf, OutBytes);
 
353
        strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 
354
        strm.avail_out := BufInc;
 
355
      end;
 
356
    finally
 
357
      DCheck(inflateEnd(strm));
 
358
    end;
 
359
    ReallocMem(OutBuf, strm.total_out);
 
360
    OutBytes := strm.total_out;
 
361
  except
 
362
    FreeMem(OutBuf);
 
363
    raise
 
364
  end;
 
365
end;
 
366
 
 
367
 
 
368
// TCustomZlibStream
 
369
 
 
370
constructor TCustomZLibStream.Create(Strm: TStream);
 
371
begin
 
372
  inherited Create;
 
373
  FStrm := Strm;
 
374
  FStrmPos := Strm.Position;
 
375
end;
 
376
 
 
377
procedure TCustomZLibStream.Progress(Sender: TObject);
 
378
begin
 
379
  if Assigned(FOnProgress) then FOnProgress(Sender);
 
380
end;
 
381
 
 
382
 
 
383
// TCompressionStream
 
384
 
 
385
constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
 
386
  Dest: TStream);
 
387
const
 
388
  Levels: array [TCompressionLevel] of ShortInt =
 
389
    (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
 
390
begin
 
391
  inherited Create(Dest);
 
392
  FZRec.next_out := FBuffer;
 
393
  FZRec.avail_out := sizeof(FBuffer);
 
394
  CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
 
395
end;
 
396
 
 
397
destructor TCompressionStream.Destroy;
 
398
begin
 
399
  FZRec.next_in := nil;
 
400
  FZRec.avail_in := 0;
 
401
  try
 
402
    if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 
403
    while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
 
404
      and (FZRec.avail_out = 0) do
 
405
    begin
 
406
      FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 
407
      FZRec.next_out := FBuffer;
 
408
      FZRec.avail_out := sizeof(FBuffer);
 
409
    end;
 
410
    if FZRec.avail_out < sizeof(FBuffer) then
 
411
      FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
 
412
  finally
 
413
    deflateEnd(FZRec);
 
414
  end;
 
415
  inherited Destroy;
 
416
end;
 
417
 
 
418
function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
 
419
begin
 
420
  raise ECompressionError.Create('Invalid stream operation');
 
421
end;
 
422
 
 
423
function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
 
424
begin
 
425
  FZRec.next_in := @Buffer;
 
426
  FZRec.avail_in := Count;
 
427
  if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 
428
  while (FZRec.avail_in > 0) do
 
429
  begin
 
430
    CCheck(deflate(FZRec, 0));
 
431
    if FZRec.avail_out = 0 then
 
432
    begin
 
433
      FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 
434
      FZRec.next_out := FBuffer;
 
435
      FZRec.avail_out := sizeof(FBuffer);
 
436
      FStrmPos := FStrm.Position;
 
437
      Progress(Self);
 
438
    end;
 
439
  end;
 
440
  Result := Count;
 
441
end;
 
442
 
 
443
function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 
444
begin
 
445
  if (Offset = 0) and (Origin = soFromCurrent) then
 
446
    Result := FZRec.total_in
 
447
  else
 
448
    raise ECompressionError.Create('Invalid stream operation');
 
449
end;
 
450
 
 
451
function TCompressionStream.GetCompressionRate: Single;
 
452
begin
 
453
  if FZRec.total_in = 0 then
 
454
    Result := 0
 
455
  else
 
456
    Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
 
457
end;
 
458
 
 
459
 
 
460
// TDecompressionStream
 
461
 
 
462
constructor TDecompressionStream.Create(Source: TStream);
 
463
begin
 
464
  inherited Create(Source);
 
465
  FZRec.next_in := FBuffer;
 
466
  FZRec.avail_in := 0;
 
467
  DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
 
468
end;
 
469
 
 
470
destructor TDecompressionStream.Destroy;
 
471
begin
 
472
  inflateEnd(FZRec);
 
473
  inherited Destroy;
 
474
end;
 
475
 
 
476
function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
 
477
begin
 
478
  FZRec.next_out := @Buffer;
 
479
  FZRec.avail_out := Count;
 
480
  if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 
481
  while (FZRec.avail_out > 0) do
 
482
  begin
 
483
    if FZRec.avail_in = 0 then
 
484
    begin
 
485
      FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
 
486
      if FZRec.avail_in = 0 then
 
487
        begin
 
488
          Result := Count - FZRec.avail_out;
 
489
          Exit;
 
490
        end;
 
491
      FZRec.next_in := FBuffer;
 
492
      FStrmPos := FStrm.Position;
 
493
      Progress(Self);
 
494
    end;
 
495
    DCheck(inflate(FZRec, 0));
 
496
  end;
 
497
  Result := Count;
 
498
end;
 
499
 
 
500
function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
 
501
begin
 
502
  raise EDecompressionError.Create('Invalid stream operation');
 
503
end;
 
504
 
 
505
function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 
506
var
 
507
  I: Integer;
 
508
  Buf: array [0..4095] of Char;
 
509
begin
 
510
  if (Offset = 0) and (Origin = soFromBeginning) then
 
511
  begin
 
512
    DCheck(inflateReset(FZRec));
 
513
    FZRec.next_in := FBuffer;
 
514
    FZRec.avail_in := 0;
 
515
    FStrm.Position := 0;
 
516
    FStrmPos := 0;
 
517
  end
 
518
  else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
 
519
          ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
 
520
  begin
 
521
    if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
 
522
    if Offset > 0 then
 
523
    begin
 
524
      for I := 1 to Offset div sizeof(Buf) do
 
525
        ReadBuffer(Buf, sizeof(Buf));
 
526
      ReadBuffer(Buf, Offset mod sizeof(Buf));
 
527
    end;
 
528
  end
 
529
  else
 
530
    raise EDecompressionError.Create('Invalid stream operation');
 
531
  Result := FZRec.total_out;
 
532
end;
 
533
 
 
534
end.