Annotation of src/external/gpl3/binutils/dist/zlib/contrib/delphi/ZLib.pas, Revision 1.1
1.1 ! christos 1: {*******************************************************}
! 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.7';
! 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.
CVSweb <webmaster@jp.NetBSD.org>