Chip 2001 September/Chip_2001-09_cd1.bin/zkuste/delphi/unity/d5/JRZIP.ZIP/JRZip.pas

Pascal/Delphi Source File | 2001-01-25 | 12.5 KB | 440 lines

{ ---------------------------------------------------------------
  Delphi-Unit
  Subroutines for packing files
  Supports:
  gz-Format: packing and unpacking
    gz-files include original filename and timestamp
    calling:
    - GZip (Source,Destination)
    - GUnzip (Source,Destination)

   PkZip-Format: packing
    calling:
    - MakeZip (Destination,BasicDirectory)
    - AddZip (Source)
    - CloseZip
  all error handling using exceptions

  acknowledgments:
  - uses a modified version of gzio from Jean-Loup Gailly and Francisco Javier Crespo
  - uses the zlib-library from Jean-Loup Gailly and Mark Adler
  J. Rathlev, Uni-Kiel ([e-mail])
  Jan. 2001
}
unit JRZip;

interface

uses
  Windows, Sysutils, Classes, GzIOExt;

  const
    GzExt = '.gz';
    BUFLEN = 16384;

  type
  TCompressionType = (ctStandard,ctFiltered,ctHuffmanOnly);
  EGZipError = class(EInOutError);

  TPkHeader = class(TObject)
    TimeStamp,Offset,
    CRC,CSize,USize : cardinal;
    Attr            : integer;
    end;

{ ---------------------------------------------------------------- }
(* set then compression level from 1 .. 9
            metho to "Standard, Filtered or HuffmanOnly"
   default: Standard, 6 *)
procedure SetCompression (Method : TCompressionType;
                          Level  : integer);

{ ---------------------------------------------------------------- }
(* copy source to destination producing gz-file *)
procedure Gzip (Source,Destination : string);

(* copy source to destination retrieving from gz-file *)
procedure Gunzip (Source,Destination : string);

{ ---------------------------------------------------------------- }
(* open Destination as PkZip compatible archive,
  all added files are relative to BasicDirectory *)
procedure MakeZip (Destination,BasicDirectory : string);

(* add Source to Pk-Archive *)
procedure AddZip (Source : string);

(* close Pk-Archive, write trailer *)
procedure CloseZip;

{ ---------------------------------------------------------------- }
implementation

var
  CLevel : integer;
  CType  : TCompressionType;
  PBase,PDest : string;
  FileList    : TStringList;

procedure SetCompression (Method : TCompressionType;
                          Level  : integer);
begin
  CLevel:=Level; CType:=Method;
  end;

{ gz_compress ----------------------------------------------
# This code comes from minigzip.pas with some changes
# Original:
# minigzip.c -- usage example of the zlib compression library
# Copyright (C) 1995-1998 Jean-loup Gailly.
#
# Pascal tranlastion
# Copyright (C) 1998 by Jacques Nomssi Nzali
#
# 0 - No Error
# 1 - Read Error
# 2 - Write Error
-----------------------------------------------------------}
function gz_compress (var infile : file;
                      outfile    : gzFile): integer;
var
  len   : integer;
  ioerr : integer;
  buf   : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
  errorcode : byte;
  fsize, lensize : longword;

begin
  errorcode := 0;
  fsize := FileSize(infile);
  lensize := 0;
  while true do begin
    {$I-} blockread (infile, buf, BUFLEN, len); {$I+}
    ioerr := IOResult;
    if (ioerr <> 0) then begin
      errorcode := 1;
      break;
    end;
    if (len = 0) then break;
    {$WARNINGS OFF}{Comparing signed and unsigned types}
    if (gzwrite (outfile, @buf, len) <> len) then begin
    {$WARNINGS OFF}
      errorcode := 2;
      break
    end;
  end; {WHILE}
  closeFile (infile);
  gz_compress := errorcode;
  end;

{ gz_uncompress ----------------------------------------------
# This code comes from minigzip.pas with some changes
# Original:
# minigzip.c -- usage example of the zlib compression library
# Copyright (C) 1995-1998 Jean-loup Gailly.
#
# Pascal tranlastion
# Copyright (C) 1998 by Jacques Nomssi Nzali
#
# 0 - No error
# 1 - Read Error
# 2 - Write Error
-----------------------------------------------------------}
function gz_uncompress (infile      : gzFile;
                        var outfile : file;
                   fsize       : longword) : integer;
var
  len     : integer;
  written : integer;
  ioerr   : integer;
  buf     : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
  errorcode : byte;
  lensize : longword;
begin
  errorcode := 0;
  lensize := 0;
  while true do begin
    len := gzread (infile, @buf, BUFLEN);
    if (len < 0) then begin
      errorcode := 1;
      break
      end;
    if (len = 0) then break;
    {$I-} blockwrite (outfile, buf, len, written); {$I+}
    {$WARNINGS OFF}{Comparing signed and unsigned types}
    if (written <> len) then begin
    {$WARNINGS ON}
       errorcode := 2;
       break
       end;
    end; {WHILE}
  try
    closefile (outfile);
  except
    errorcode := 3
    end;
  gz_uncompress := errorcode
  end;

{ Gzip --------------------------------------------------------}
procedure Gzip (Source,Destination : string);
var
  outmode : string;
  s       : string;
  outFile : gzFile;
  infile  : file;
  errorcode : integer;
  size      : cardinal;
  time,dt   : TDateTime;
  ftime,
  utime     : cardinal;
  tz        : TIME_ZONE_INFORMATION;
  Handle    : Integer;
begin
  AssignFile (infile, Source);
  try
    FileMode:=0;
    Reset (infile,1);
    FileMode:=2;
    size:=filesize(infile);
    outmode := 'w  ';
    s := IntToStr(CLevel);
    outmode[2] := s[1];
    case CType of
       ctHuffmanOnly : outmode[3] := 'h';
       ctFiltered    : outmode[3] := 'f';
      end;
    s:=ExtractFilename(Source);
    ftime:=FileAge(Source);
    time:=FileDateToDateTime(ftime);
    if GetTimeZoneInformation(tz)=-1 then dt:=0 else dt:=tz.bias/1440;
    utime:=round(SecsPerDay*(time+dt-25569));
    outFile := gzopen (Destination,outmode,s,utime);
    if (outFile = NIL) then begin
      raise EGZipError.Create ('Error opening '+Destination);
      close(infile);
      end
    else begin
      errorcode := gz_compress(infile, outFile);
      if errorcode > 0 then begin
        case errorcode of
        1 : raise EGZipError.Create ('Error reading from '+Source);
        2 : raise EGZipError.Create ('Error writing to '+Destination);
          end;
        end
      else begin
        if (gzclose (outFile) <> 0{Z_OK}) then
           raise EGZipError.Create ('Error closing '+Destination);
        (* set time stamp of gz-file *)
        Handle := FileOpen(Destination, fmOpenWrite);
        FileSetDate(Handle,ftime);
        FileClose(Handle);
        end;
      end;
  except
    on EInOutError do
      raise EGZipError.Create ('Error opening '+Source);
    end;
  end;

{ GUnzip ------------------------------------------------------}
procedure Gunzip (Source,Destination : string);
var
  infile     : gzFile;
  outfile, f : file;
  errorcode : integer;
  fsize     : longword;
  s         : string;
  dt        : TDateTime;
  ftime,
  utime     : cardinal;
  tz        : TIME_ZONE_INFORMATION;
  Handle    : Integer;
begin
  AssignFile( f, Source);
  try
    FileMode:=0;
    Reset( f, 1);
    FileMode:=2;
    fsize := FileSize( f);
    Close( f);
    infile := gzopen (Source, 'r',s,utime);
    if (infile = NIL) then begin
      raise EGZipError.Create ('Error opening '+Destination);
      end
    else begin
      if length(s)>0 then s:=Destination+s
      else s:=Destination+ChangeFileExt(ExtractFilename(Source),'');
      AssignFile (outfile, s);
      try
        Rewrite (outfile,1);
        s:=Destination+ChangeFileExt(ExtractFilename(Source),'');
        errorcode:=gz_uncompress (infile, outfile, fsize);
        if errorcode>0 then begin
          case errorcode of
          1 : raise EGZipError.Create ('Error reading from '+Source);
          2 : raise EGZipError.Create ('Error writing to '+Destination);
            end;
          end
        else begin
          (* set time stamp of gz-file *)
          if GetTimeZoneInformation(tz)=-1 then dt:=0 else dt:=tz.bias/1440;
          ftime:=DateTimeToFileDate(utime/SecsPerDay-dt+25569);
          Handle := FileOpen(s, fmOpenWrite);
          FileSetDate(Handle,ftime);
          FileClose(Handle);
          end;
      except
        on EInOutError do
            raise EGZipError.Create ('Error opening '+Destination);
        end;
      end
  except
    on EInOutError do
      raise EGZipError.Create ('Error opening '+Source);
    end;
  end;

{ MakeZip -----------------------------------------------------
  Open archive for AddZip
---------------------------------------------------------------}
procedure MakeZip (Destination,BasicDirectory : string);
var
  f : file;
begin
  FileList:=TStringList.Create;
  FileList.Sorted:=false;
  PDest:=Destination; PBase:=BasicDirectory;
  AssignFile (f,Destination);
  ReWrite (f,1);
  CloseFile (f);
  end;

{ AddZip ---JR--------------------------------------------------
  Add "Source" to open archive (see MakeZip)
---------------------------------------------------------------}
procedure AddZip (Source : string);
var
  outmode   : string;
  s         : string;
  outFile   : gzFile;
  infile    : file;
  ioerr     : integer;
  errorcode : integer;
  size      : cardinal;
  utime     : cardinal;
  Header    : TPkHeader;
begin
  if length (PDest)>0 then begin
    AssignFile (infile, Source);
    try
      FileMode:=0;
      Reset (infile,1);
      FileMode:=2;
      size:=filesize(infile);
      case CType of
         ctHuffmanOnly : outmode:='h';
         ctFiltered    : outmode:='f';
        end;
      outmode := outmode+copy(IntToStr(cLevel),1,1);
      s:=ExtractRelativePath(PBase,Source);
      utime:=FileAge(Source);
      outFile := ZipOpen (PDest, outmode,s,utime);
      if (outFile = NIL) then begin
        raise EGZipError.Create ('Error opening '+PDest);
        close(infile);
        end
      else begin
        errorcode := gz_compress(infile, outFile);
        if errorcode > 0 then begin
          case errorcode of
          1 : raise EGZipError.Create ('Error reading from '+Source);
          2 : raise EGZipError.Create ('Error writing to '+PDest);
            end;
          end
        else begin
          if ZipClose(outfile)<>0 then begin
            raise EGZipError.Create ('Error closing '+PDest);
            end
          else begin
            Header:=TPkHeader.Create;
            with outfile^ do begin
              Header.Timestamp:=time;
              Header.CRC:=CRC;
              Header.CSize:=CSize;
              Header.USize:=USize;
              Header.Attr:=FileGetAttr(Source);
              Header.Offset:=filepos;
              end;
            FreeMem(outfile,sizeof(gz_stream));
            FileList.Addobject(s,Header);
            end;
          end;
        end;
    except
      on EInOutError do
        raise EGZipError.Create ('Error opening '+Source);
      end;
    end;
  end;

{ CloseZip -----------------------------------------------------
  Write directory and final block
---------------------------------------------------------------}
procedure CloseZip;
var
  f : file;
  pke : TPkEndHeader;
  pkd : TPkDirHeader;
  off : cardinal;
  i   : integer;
  s   : string[255];
begin
  if length (PDest)>0 then begin
    AssignFile (f,PDest);
    reset (f,1);
    off:=filesize(f); seek (f,off);
    with FileList do for i:=0 to Count-1 do begin
      with pkd do begin
        Signatur:=PkDirSignatur;
        VersMade:=$14;
        VersExtr:=$14;
        Flag:=2;
        Method:=8;
        FTimeStamp:=(Objects[i] as TPkHeader).TimeStamp;
        CRC:=(Objects[i] as TPkHeader).CRC;
        CSize:=(Objects[i] as TPkHeader).CSize;
        USize:=(Objects[i] as TPkHeader).USize;
        FNLength:=length(Strings[i]);
        ExtraLength:=0;
        CommLength:=0;
        DiskStart:=0;
        IntAttr:=0;
        ExtAttr:=(Objects[i] as TPkHeader).Attr;
        Offset:=(Objects[i] as TPkHeader).Offset;
        end;
      blockwrite (f,pkd,sizeof(pkd));
      s:=Strings[i];
      blockwrite (f,s[1],pkd.FNLength);
      end;
    with pke do begin
      Signatur:=PkEndSignatur;
      ThisDisk:=0;
      StartDisk:=0;
      ThisEntries:=FileList.Count;
      TotalEntries:=FileList.Count;
      DirSize:=filepos(f)-off;
      Offset:=off;
      CommLength:=0;
      end;
    blockwrite (f,pke,sizeof(pke));
    CloseFile (f);
    FileList.Free;
    PDest:='';
    end;
  end;

begin
  PDest:=''; PBase:='';
  CLevel:=6; CType:=ctStandard;
  end.