vs_compress.pas

KSDev.VirtualSream.v1.01.rar 虚拟文件系统,

                              dictionary : pBytef; 
                              dictLength : uInt) : int;

{
     Initializes the decompression dictionary from the given uncompressed byte
   sequence. This function must be called immediately after a call of inflate
   if this call returned Z_NEED_DICT. The dictionary chosen by the compressor
   can be determined from the Adler32 value returned by this call of
   inflate. The compressor and decompressor must use exactly the same
   dictionary (see deflateSetDictionary).

     inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
   parameter is invalid (such as NULL dictionary) or the stream state is
   inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
   expected one (incorrect Adler32 value). inflateSetDictionary does not
   perform any decompression: this will be done by subsequent calls of
   inflate().
}

function inflateSync(var z : z_stream) : int;

{
  Skips invalid compressed data until a full flush point (see above the
  description of deflate with Z_FULL_FLUSH) can be found, or until all
  available input is skipped. No output is provided.

    inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
  if no more input was provided, Z_DATA_ERROR if no flush point has been found,
  or Z_STREAM_ERROR if the stream structure was inconsistent. In the success
  case, the application may save the current current value of total_in which
  indicates where valid compressed data was found. In the error case, the
  application may repeatedly call inflateSync, providing more input each time,
  until success or end of the input data.
}


function inflateSyncPoint(var z : z_stream) : int;

{ZKsInfTrees}
{ Maximum size of dynamic tree.  The maximum found in a long but non-
  exhaustive search was 1004 huft structures (850 for length/literals
  and 154 for distances, the latter actually the result of an
  exhaustive search).  The actual maximum is not known, but the
  value below is more than safe. }
const
  MANY = 1440;


{$ifdef DEBUG}
var
  inflate_hufts : uInt;
{$endif}

function inflate_trees_bits(
  var c : array of uIntf;  
  var bb : uIntf;          
  var tb : pinflate_huft;  { !ignore me! bits tree result }
  var hp : array of Inflate_huft;      { !ignore me!space for trees }
  var z : z_stream         { !ignore me!for messages }
    ) : int;

function inflate_trees_dynamic(
    nl : uInt;                    { !ignore me!number of literal/length codes }
    nd : uInt;                    { !ignore me!number of distance codes }
    var c : Array of uIntf;           { !ignore me!that many (total) code lengths }
    var bl : uIntf;               { !ignore me!literal desired/actual bit depth }
    var bd : uIntf;               { !ignore me!distance desired/actual bit depth }
var tl : pInflate_huft;           { !ignore me!literal/length tree result }
var td : pInflate_huft;           { !ignore me!distance tree result }
var hp : array of Inflate_huft;   { !ignore me!space for trees }
var z : z_stream                  { !ignore me!for messages }
     ) : int;

function inflate_trees_fixed (
    var bl : uInt;                { !ignore me!literal desired/actual bit depth }
    var bd : uInt;                { !ignore me!distance desired/actual bit depth }
    var tl : pInflate_huft;       { !ignore me!literal/length tree result }
    var td : pInflate_huft;       { !ignore me!distance tree result }
    var z : z_stream              { !ignore me!for memory allocation }
     ) : int;


{ZKsInfUtil}
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
                       var z : z_stream;
                       r : int) : int;

{ And'ing with mask[n] masks the lower n bits }
const
  inflate_mask : array[0..17-1] of uInt = (
    $0000,
    $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
    $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);

{procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);}


{ZKSTrees}
const
  LENGTH_CODES = 29;
  LITERALS = 256;
  L_CODES = (LITERALS+1+LENGTH_CODES);
  D_CODES = 30;
  BL_CODES = 19;
  HEAP_SIZE = (2*L_CODES+1);
  MAX_BITS = 15;

  INIT_STATE =  42;
  BUSY_STATE =  113;
  FINISH_STATE = 666;

type
  ct_data_ptr = ^ct_data;
  ct_data = record
    fc : record
      case byte of
      0:(freq : ush);       { frequency count }
      1:(code : ush);       { bit string }
    end;
    dl : record
      case byte of
      0:(dad : ush);        { father node in Huffman tree }
      1:(len : ush);        { length of bit string }
    end;
  end;

  ltree_type = array[0..HEAP_SIZE-1] of ct_data;    { literal and length tree }
  dtree_type = array[0..2*D_CODES+1-1] of ct_data;  { distance tree }
  htree_type = array[0..2*BL_CODES+1-1] of ct_data;  { Huffman tree for bit lengths }
  { generic tree type }
  tree_type = array[0..(MaxInt div SizeOf(ct_data))-1] of ct_data;

  tree_ptr = ^tree_type;
  ltree_ptr = ^ltree_type;
  dtree_ptr = ^dtree_type;
  htree_ptr = ^htree_type;


  static_tree_desc_ptr = ^static_tree_desc;
  static_tree_desc =
         record
    {const} static_tree : tree_ptr;     { static tree or NIL }
    {const} extra_bits : pzIntfArray;   { extra bits for each code or NIL }
            extra_base : int;           { base index for extra_bits }
            elems : int;                { max number of elements in the tree }
            max_length : int;           { max bit length for the codes }
          end;

  tree_desc_ptr = ^tree_desc;
  tree_desc = record
    dyn_tree : tree_ptr;    { the dynamic tree }
    max_code : int;            { largest code with non zero frequency }
    stat_desc : static_tree_desc_ptr; { the corresponding static tree }
  end;

  Pos = ush;
  Posf = Pos; {FAR}
  IPos = uInt;

  pPosf = ^Posf;

  zPosfArray = array[0..(MaxInt div SizeOf(Posf))-1] of Posf;
  pzPosfArray = ^zPosfArray;

  deflate_state_ptr = ^deflate_state;
  deflate_state = record
    strm : z_streamp;          { pointer back to this zlib stream }
    status : int;              { as the name implies }
    pending_buf : pzByteArray; { output still pending }
    pending_buf_size : ulg;    { size of pending_buf }
    pending_out : pBytef;      { next pending byte to output to the stream }
    pending : int;             { nb of bytes in the pending buffer }
    noheader : int;            { suppress zlib header and adler32 }
    data_type : Byte;          { UNKNOWN, BINARY or ASCII }
    method : Byte;             { STORED (for zip only) or DEFLATED }
    last_flush : int;          { value of flush param for previous deflate call }


    w_size : uInt;             { LZ77 window size (32K by default) }
    w_bits : uInt;             { log2(w_size)  (8..16) }
    w_mask : uInt;             { w_size - 1 }

    window : pzByteArray;
    window_size : ulg;

    prev : pzPosfArray;

    head : pzPosfArray;    { Heads of the hash chains or NIL. }

    ins_h : uInt;          { hash index of string to be inserted }
    hash_size : uInt;      { number of elements in hash table }
    hash_bits : uInt;      { log2(hash_size) }
    hash_mask : uInt;      { hash_size-1 }

    hash_shift : uInt;

    block_start : long;

    match_length : uInt;           { length of best match }
    prev_match : IPos;             { previous match }
    match_available : boolean;     { set if previous match exists }
    strstart : uInt;               { start of string to insert }
    match_start : uInt;            { start of matching string }
    lookahead : uInt;              { number of valid bytes ahead in window }

    prev_length : uInt;

    max_chain_length : uInt;

    level : int;    { compression level (1..9) }
    strategy : int; { favor or force Huffman coding}

    good_match : uInt;

    nice_match : int; { Stop searching when current match exceeds this }

    dyn_ltree : ltree_type;    { literal and length tree }
    dyn_dtree : dtree_type;  { distance tree }
    bl_tree : htree_type;   { Huffman tree for bit lengths }

    l_desc : tree_desc;                { desc. for literal tree }
    d_desc : tree_desc;                { desc. for distance tree }
    bl_desc : tree_desc;               { desc. for bit length tree }

    bl_count : array[0..MAX_BITS+1-1] of ush;

    heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees }
    heap_len : int;                   { number of elements in the heap }
    heap_max : int;                   { element of largest frequency }

    depth : array[0..2*L_CODES+1-1] of uch;

    l_buf : puchfArray;       { buffer for literals or lengths }

    lit_bufsize : uInt;

    last_lit : uInt;      { running index in l_buf }

    d_buf : pushfArray;

    opt_len : ulg;        { bit length of current block with optimal trees }
    static_len : ulg;     { bit length of current block with static trees }
    compressed_len : ulg; { total bit length of compressed file }
    matches : uInt;       { number of string matches in current block }
    last_eob_len : int;   { bit length of EOB code for last block }

{$ifdef DEBUG}
    bits_sent : ulg;    { bit length of the compressed data }
{$endif}

    bi_buf : ush;

    bi_valid : int;

    case byte of
    0:(max_lazy_match : uInt);

    1:(max_insert_length : uInt);
  end;

procedure _tr_init (var s : deflate_state);

function _tr_tally (var s : deflate_state;
                    dist : unsigned;
                    lc : unsigned) : boolean;

function _tr_flush_block (var s : deflate_state;
                          buf : pcharf;
                          stored_len : ulg;
			  eof : boolean) : ulg;

procedure _tr_align(var s : deflate_state);

procedure _tr_stored_block(var s : deflate_state;
                           buf : pcharf;
                           stored_len : ulg;
                           eof : boolean);



type
  TAlloc = alloc_func;
    {function (AppData: Pointer; Items, Size: Integer): Pointer;}
  TFree = free_func;
    {procedure (AppData, Block: Pointer);}

  { Internal structure.  Ignore. }
  TZStreamRec = z_stream;

const
  FBufSize = 8192;
type
  { Abstract ancestor class }
  TCustomZlibStream = class(TStream)
  private
    FStrm: TStream;
    FStrmPos: Integer;
    FOnProgress: TNotifyEvent;
    FZRec: TZStreamRec;
    FBuffer: array [0..FBufSize-1] of Char;
  protected
    procedure Progress(Sender: TObject); dynamic;
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
    constructor Create(Strm: TStream);
  end;

{ TCompressionStream compresses data on the fly as data is written to it, and
  stores the compressed data to another stream.

  TCompressionStream is write-only and strictly sequential. Reading from the
  stream will raise an exception. Using Seek to move the stream pointer
  will raise an exception.

  Output data is cached internally, written to the output stream only when
  the internal output buffer is full.  All pending output data is flushed
  when the stream is destroyed.

  The Position property returns the number of uncompressed bytes of
  data that have been written to the stream so far.

  CompressionRate returns the on-the-fly percentage by which the original
  data has been compressed:  (1 - (CompressedBytes / UncompressedBytes)) * 100
  If raw data size = 100 and compressed data size = 25, the CompressionRate
  is 75%

  The OnProgress event is called each time the output buffer is filled and
  written to the output stream.  This is useful for updating a progress
  indicator when you are writing a large chunk of data to the compression
  stream in a single call.}


  TCompressionLevel = (clNone, clFastest, clDefault, clMax);

  TCompressionStream = class(TCustomZlibStream)
  private
    function GetCompressionRate: Single;
  public
    constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    property CompressionRate: Single read GetCompressionRate;
    property OnProgress;
  end;