OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [zlib/] [contrib/] [delphi/] [ZLib.pas] - Blame information for rev 745

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.