kpunzipp.pas

一个delphi中压缩的组件VCLZip

{ ********************************************************************************** }
{                                                                                    }
{   COPYRIGHT 1997 Kevin Boylan                                                    }
{     Source File: Unzipp.pas                                                        }
{     Description: VCLUnZip component - native Delphi unzip component.               }
{     Date:        March 1997                                                        }
{     Author:      Kevin Boylan, [e-mail]                                 }
{                                                                                    }
{                                                                                    }
{ ********************************************************************************** }


{$P-} { turn off open parameters }
{$Q-} { turn off overflow checking }
{$R-} { turn off range checking }
{$B-} { turn off complete boolean eval } { 12/24/98  2.17 }

function TVCLUnZip.UnZipFiles( zip_in_file: TStream ): Integer;
var
   csize: LongInt;
    ucsize: LongInt;
    area: ^work;
    outcnt: WORD;
    hufts: WORD;
    slide: slidearrayptr;
   inbuf,
    inptr,
    outbuf,
    outptr: BYTEPTR;
    incnt: WORD;
    bitbuf: U_LONG;
    bits_left: WORD;
    zipeof: LongBool;
    outpos: LongInt;
    zip_out_file: TStream;
    bytebuf: WORD;
    FileCount: Integer;
    RepeatFile: Boolean;
    NumUnZipped: Integer;
    Retry: Boolean;

{$I kpFile.Pas}

{****************************************************************************}
function huft_free(var t: huftptr): short_int;
var
 p: huftarrayptr;
  q,z:   huftptr;
begin
{ t =  table to free }
{ Free the malloc'ed tables built by huft_build(), which makes a linked
   list of the tables it made, with the links in a dummy first entry of
   each table. }
{ Go through linked lIst, freeing from the malloced (t[-1]) address. }
  z := t;
try
  while (z <> nil) do
   begin
     Dec(z);
     p := huftarrayptr(z);
     q := z^.v.t;
     StrDispose( PChar(p) );
     {FreeMem(p);}
     z := q;
   end;
  t := nil;
  Result := 0;
except
  t := nil;
  Result := 1;
  exit;
end;
end;

{****************************************************************************}
function huft_build(b: array of WORD; n,s: WORD; d,e: array of WORD;
        t:huftptrptr; var m: short_int): short_int;
{ b =   code lengths in bits (all assumed <= BMAX) }
{ n =  number of codes (assumed <= N_MAX)     }
{ s =  number of simple-valued codes (0..s-1)   }
{ d =  list of base values for non-simple codes   }
{ e =  list of extra bits for non-simple codes   }
{ t =  result: starting table         }
{ m =  maximum lookup bits, returns actual    }
{ Given a list of code lengths and a maximum table size, make a set of
   tables to decode that set of codes.  Return zero on success, one if
   the given code set is incomplete (the tables are still built in this
   case), two if the input is invalid (all zero length codes or an
   oversubscribed set of lengths), and three if not enough memory. }
var
  a:  WORD;                    { counter for codes of length k }
  c:  array[0..BMAX] of WORD;  { bit length count table }
  f:  WORD;                    { i repeats in table every f entries }
  g:  short_int;                   { maximum code length }
  h:  short_int;                   { table level }
  i:  WORD;              { counter, current code }
  j:  WORD;              { counter }
  k:  short_int;                 { number of bits in current code }
  l:  short_int;                    { bits per table (returned in m) }
  p:  Integer;             { pointer into c[], b[], or v[] }
  q:  huftarrayptr;      { points to current table }
  r:  huft;                  { table entry for structure assignment }
  u:  array[0..BMAX-1] of huftarrayptr; { table stack }
 v:  array[0..N_MAX-1] of WORD; { values in order of bit length }
  w:  short_int;                 { bits before this table == (l * h) }
  x:  array[0..BMAX] of WORD;   { bit offsets, then code stack }
  xp: Integer;                  { pointer into x }
  y:  short_int;                  { number of dummy codes added }
  z:  WORD;                    { number of entries in current table }
begin
  { Generate counts for each bit length }
{$IFNDEF KPSMALL}
try
{$ENDIF}
 ZeroMemory(@c, SizeOf(c));
  p := 0;
  i := n;
  Repeat
    Inc(c[b[p]]);
    Inc(p);
    Dec(i);                  { assume all entries <= BMAX }
  Until (i=0);
  if (c[0] = n) then               { null input--all zero length codes }
   begin
     t^ := nil;
     m := 0;
     Result := 0;
     exit;
   end;

 { Find minimum and maximum length, bound *m by those }
  l := m;
  j := 1;
  while ((j<=BMAX) and (c[j]=0)) do
   Inc(j);
  k := j;                        { minimum code length }
  if (WORD(l) < j) then
    l := j;
  i := BMAX;
  while ((i>0) and (c[i]=0)) do   { changed from >= 7/19/98  2.14}
   Dec(i);
  g := i;                        { maximum code length }
  if (WORD(l) > i) then
    l := i;
  m := l;

  { Adjust last length count to fill out codes, if needed }
  y := short_int(1 shl j);
  while (j<i) do
   begin
    Dec(y,c[j]);
     if y < 0 then
      begin
       Result := 2;
        exit;
      end;
    y := short_int(y shl 1);
     Inc(j);
   end;
  Dec(y,c[i]);
  if y < 0 then
   begin
    Result := 2;
     exit;
   end;
  Inc(c[i],y);

 { Generate starting offsets into the value table for each length }
  x[1] := 0;
  j := 0;
  p := 1;
  xp := 2;
  Dec(i);
  while (i>0) do                 { note that i == g from above }
   begin
    Inc(j,c[p]);
     Inc(p);
     x[xp] := j;
     Inc(xp);
     Dec(i);
   end;

 { Make a table of values in order of bit lengths }
  p := 0;  i := 0;
  Repeat
   j := b[p];
     Inc(p);
     if (j <> 0) then
      begin
      v[x[j]] := i;
        Inc(x[j]);
      end;
   Inc(i);
  Until (i>=n);

  { Generate the Huffman codes and for each, make the table entries }
  x[0] := 0;
  i := 0;                 { first Huffman code is zero }
  p := 0;             { grab values in bit order }
  h := -1;                { no tablEs yet--level -1 }
  w := -l;                { bits decoded == (l * h) }
  u[0] := nil;      { just to keep compilers happy }
  q := nil;         { ditto }
  z := 0;                 { ditto }

 { go through the bit lengths (k already is bits in shortest code) }
  while ( k <= g ) do
   begin
     a := c[k];
     while (a <> 0) do
      begin
       Dec(a);
       { here i is the Huffman code of length k bits for value *p }
       { make tables up to required level }
       while (k > (w + l)) do
        begin
           Inc(h);
           Inc(w,l);                 { previous table always l bits }
           { compute minimum size table less than or equal to l bits }
           z := g - w;
           if (z > WORD(l)) then
              z := l;
           j := k - w;
           f := WORD(WORD(1) shl j);
           if (f > (a+1)) then      { too few codes for k-w bit table }
            begin
              Dec(f,(a+1));         { deduct codes from patterns left }
              xp := k;
              Inc(j);
              while (j < z) do       { try smaller tables up to z bits }
               begin
                 f := WORD(f shl 1);
                 Inc(xp);
                 if (f <= c[xp]) then
                 break;            { enough codes to use up j bits }
                 Dec(f,c[xp]);     { else deduct codes from patterns }
                 Inc(j);
               end;
            end;
           z := WORD(WORD(1) shl j);             { table entries for j-bit table }

         { allocate and link in new table }
           try
              q := huftarrayptr( StrAlloc((z+1)*SizeOf(huft)));
              {GetMem( q, (z+1)*SizeOf(huft));}
           except
              if (h <> 0) then
               begin
                 t^ := @u[0]^[0];
                 huft_free(t^);
               end;
              {$IFDEF NO_RES}
              MessageBox(0, '*** inflate out of memory ***','Error',mb_OK );
              {$ELSE}
              tmpMStr := LoadStr(IDS_LOWMEM);
              MessageBox(0, StringAsPChar(tmpMStr),'Error',mb_OK );
              {$ENDIF}
              Result := 3;
              exit;
           end;

           if q = nil then
            begin
              if (h <> 0) then
               begin
                 t^ := @u[0]^[0];
                 huft_free(t^);
               end;
              {$IFDEF NO_RES}
              MessageBox(0, '*** inflate out of memory ***','Error',mb_OK );
              {$ELSE}
              tmpMStr := LoadStr(IDS_LOWMEM);
              MessageBox(0, StringAsPChar(tmpMStr),'Error',mb_OK );
              {$ENDIF}
              Result := 3;
              exit;
            end;

           Inc(hufts,z + 1);          { track memory usage }
           t^ := @q^[0];
           q^[-1].v.t := nil;
           t := @(q^[-1].v.t);
           { added typecast 5/18/98  2.13 }
           u[h] := huftarrayptr(@q^[0]); { table starts after link }

           { connect to last table, if there is one }
           if (h<>0) then
            begin
              x[h] := i;              { save pattern for backing up }
              r.b := BYTE(l);           { bits to dump before this table }
              r.e := BYTE(16 + j);    { bits in this table }
              r.v.t := @q^[0];         { pointer to this table }
              j := WORD(i shr (w - l));     { (get around Turbo C bug) }
              u[h-1]^[j-1] := r;         { connect to last table }
            end;
        end; { while (a <> 0) do }

        { set up table entry in r }
        r.b := BYTE(k - w);
        if (p >= n) then
           r.e := 99               { out of values--invalid code }
        else if (v[p] < s) then
         begin
           if v[p] < 256 then   { 256 is end-of-block code }
              r.e := 16
           else
              r.e := 15;
           r.v.n := v[p];           { simple code is just the value }
           Inc(p);
         end
        else
         begin
           If v[p]-s < N_MAX then
            begin
              r.e := BYTE(e[v[p] - s]);  { non-simple--look up in lists }
              r.v.n := d[v[p] - s];
              Inc(p);
            end
           Else
              r.e := 99;
         end;

      { fill code-like entries with r }
      f := WORD(WORD(1) shl (k - w));
      j := WORD(i shr w);
      while (j<z) do
       begin
        q^[j] := r;
        Inc(j,f);
       end;

      { backwards increment the k-bit code i }
      j := WORD(WORD(1) shl (k - 1));
      while ((i and j) <> 0) do
       begin
        i := i xor j;
        j := WORD(j shr 1);
       end;
      i := i xor j;

      { backup over finished tables }
      while ((i and (WORD((WORD(1) shl w))-1)) <> x[h]) do
       begin
        Dec(h);                    { don't need to update q }
        Dec(w,l);
       end;
      end;  { while (a <> 0) do }
     Inc(k);
   end;  { while ( k <= g ) do }

   If (y <> 0) and (g <> 1) then
    Result := 1
   else
    Result := 0;
{$IFNDEF KPSMALL}
except
  Result := 1;
  Exit;
end;
{$ENDIF}
end;

{****************************************************************************}
procedure flushslide(w: WORD);
var
  n: WORD;
  p: BYTEPTR;
begin
{ w = number of bytes to flush }
{ Do the equivalent of OUTB for the bytes slide[0..w-1]. }
  p := @slide^[0];
  while(w <> 0) do
   begin
    n := OUTBUFSIZ - outcnt;
    If n >= w then
      n := w;
    MoveMemory(outptr, p, n);       { try to fill up buffer }
    Inc(outptr,n);
    Inc(outcnt,n);
    If (outcnt = OUTBUFSIZ) then
      xFlushOutput;            { if full, empty }
    Inc(p,n);
    Dec(w,n);
   end;
end;

{*******************  UnZip Methods  *********************}
{$I kpInflt.Pas}
{$IFNDEF INFLATE_ONLY}
{$I kpUnrdc.Pas}
{$I kpExpld.Pas}
{$I kpUshrnk.Pas}
{$ENDIF}
{****************************************************************************}

procedure UnStore;
var
 number_to_read, number_read: Integer;
  tmpbuf: BYTEPTR;
begin
 outcnt := kpmin( file_info.compressed_size, OUTBUFSIZ );
 while( file_info.compressed_size > 0 ) do
  begin
     If DoProcessMessages then
      begin