home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / unity / d5 / JRZIP.ZIP / JRZip.pas < prev    next >
Pascal/Delphi Source File  |  2001-01-25  |  13KB  |  440 lines
  1. { ---------------------------------------------------------------
  2.   Delphi-Unit
  3.   Subroutines for packing files
  4.   Supports:
  5.   gz-Format: packing and unpacking
  6.     gz-files include original filename and timestamp
  7.     calling:
  8.     - GZip (Source,Destination)
  9.     - GUnzip (Source,Destination)
  10.  
  11.    PkZip-Format: packing
  12.     calling:
  13.     - MakeZip (Destination,BasicDirectory)
  14.     - AddZip (Source)
  15.     - CloseZip
  16.   all error handling using exceptions
  17.  
  18.   acknowledgments:
  19.   - uses a modified version of gzio from Jean-Loup Gailly and Francisco Javier Crespo
  20.   - uses the zlib-library from Jean-Loup Gailly and Mark Adler
  21.   J. Rathlev, Uni-Kiel (rathlev@physik.uni-kiel.de)
  22.   Jan. 2001
  23. }
  24. unit JRZip;
  25.  
  26. interface
  27.  
  28. uses
  29.   Windows, Sysutils, Classes, GzIOExt;
  30.  
  31.   const
  32.     GzExt = '.gz';
  33.     BUFLEN = 16384;
  34.  
  35.   type
  36.   TCompressionType = (ctStandard,ctFiltered,ctHuffmanOnly);
  37.   EGZipError = class(EInOutError);
  38.  
  39.   TPkHeader = class(TObject)
  40.     TimeStamp,Offset,
  41.     CRC,CSize,USize : cardinal;
  42.     Attr            : integer;
  43.     end;
  44.  
  45. { ---------------------------------------------------------------- }
  46. (* set then compression level from 1 .. 9
  47.             metho to "Standard, Filtered or HuffmanOnly"
  48.    default: Standard, 6 *)
  49. procedure SetCompression (Method : TCompressionType;
  50.                           Level  : integer);
  51.  
  52. { ---------------------------------------------------------------- }
  53. (* copy source to destination producing gz-file *)
  54. procedure Gzip (Source,Destination : string);
  55.  
  56. (* copy source to destination retrieving from gz-file *)
  57. procedure Gunzip (Source,Destination : string);
  58.  
  59. { ---------------------------------------------------------------- }
  60. (* open Destination as PkZip compatible archive,
  61.   all added files are relative to BasicDirectory *)
  62. procedure MakeZip (Destination,BasicDirectory : string);
  63.  
  64. (* add Source to Pk-Archive *)
  65. procedure AddZip (Source : string);
  66.  
  67. (* close Pk-Archive, write trailer *)
  68. procedure CloseZip;
  69.  
  70. { ---------------------------------------------------------------- }
  71. implementation
  72.  
  73. var
  74.   CLevel : integer;
  75.   CType  : TCompressionType;
  76.   PBase,PDest : string;
  77.   FileList    : TStringList;
  78.  
  79. procedure SetCompression (Method : TCompressionType;
  80.                           Level  : integer);
  81. begin
  82.   CLevel:=Level; CType:=Method;
  83.   end;
  84.  
  85. { gz_compress ----------------------------------------------
  86. # This code comes from minigzip.pas with some changes
  87. # Original:
  88. # minigzip.c -- usage example of the zlib compression library
  89. # Copyright (C) 1995-1998 Jean-loup Gailly.
  90. #
  91. # Pascal tranlastion
  92. # Copyright (C) 1998 by Jacques Nomssi Nzali
  93. #
  94. # 0 - No Error
  95. # 1 - Read Error
  96. # 2 - Write Error
  97. -----------------------------------------------------------}
  98. function gz_compress (var infile : file;
  99.                       outfile    : gzFile): integer;
  100. var
  101.   len   : integer;
  102.   ioerr : integer;
  103.   buf   : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
  104.   errorcode : byte;
  105.   fsize, lensize : longword;
  106.  
  107. begin
  108.   errorcode := 0;
  109.   fsize := FileSize(infile);
  110.   lensize := 0;
  111.   while true do begin
  112.     {$I-} blockread (infile, buf, BUFLEN, len); {$I+}
  113.     ioerr := IOResult;
  114.     if (ioerr <> 0) then begin
  115.       errorcode := 1;
  116.       break;
  117.     end;
  118.     if (len = 0) then break;
  119.     {$WARNINGS OFF}{Comparing signed and unsigned types}
  120.     if (gzwrite (outfile, @buf, len) <> len) then begin
  121.     {$WARNINGS OFF}
  122.       errorcode := 2;
  123.       break
  124.     end;
  125.   end; {WHILE}
  126.   closeFile (infile);
  127.   gz_compress := errorcode;
  128.   end;
  129.  
  130. { gz_uncompress ----------------------------------------------
  131. # This code comes from minigzip.pas with some changes
  132. # Original:
  133. # minigzip.c -- usage example of the zlib compression library
  134. # Copyright (C) 1995-1998 Jean-loup Gailly.
  135. #
  136. # Pascal tranlastion
  137. # Copyright (C) 1998 by Jacques Nomssi Nzali
  138. #
  139. # 0 - No error
  140. # 1 - Read Error
  141. # 2 - Write Error
  142. -----------------------------------------------------------}
  143. function gz_uncompress (infile      : gzFile;
  144.                         var outfile : file;
  145.                    fsize       : longword) : integer;
  146. var
  147.   len     : integer;
  148.   written : integer;
  149.   ioerr   : integer;
  150.   buf     : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
  151.   errorcode : byte;
  152.   lensize : longword;
  153. begin
  154.   errorcode := 0;
  155.   lensize := 0;
  156.   while true do begin
  157.     len := gzread (infile, @buf, BUFLEN);
  158.     if (len < 0) then begin
  159.       errorcode := 1;
  160.       break
  161.       end;
  162.     if (len = 0) then break;
  163.     {$I-} blockwrite (outfile, buf, len, written); {$I+}
  164.     {$WARNINGS OFF}{Comparing signed and unsigned types}
  165.     if (written <> len) then begin
  166.     {$WARNINGS ON}
  167.        errorcode := 2;
  168.        break
  169.        end;
  170.     end; {WHILE}
  171.   try
  172.     closefile (outfile);
  173.   except
  174.     errorcode := 3
  175.     end;
  176.   gz_uncompress := errorcode
  177.   end;
  178.  
  179. { Gzip --------------------------------------------------------}
  180. procedure Gzip (Source,Destination : string);
  181. var
  182.   outmode : string;
  183.   s       : string;
  184.   outFile : gzFile;
  185.   infile  : file;
  186.   errorcode : integer;
  187.   size      : cardinal;
  188.   time,dt   : TDateTime;
  189.   ftime,
  190.   utime     : cardinal;
  191.   tz        : TIME_ZONE_INFORMATION;
  192.   Handle    : Integer;
  193. begin
  194.   AssignFile (infile, Source);
  195.   try
  196.     FileMode:=0;
  197.     Reset (infile,1);
  198.     FileMode:=2;
  199.     size:=filesize(infile);
  200.     outmode := 'w  ';
  201.     s := IntToStr(CLevel);
  202.     outmode[2] := s[1];
  203.     case CType of
  204.        ctHuffmanOnly : outmode[3] := 'h';
  205.        ctFiltered    : outmode[3] := 'f';
  206.       end;
  207.     s:=ExtractFilename(Source);
  208.     ftime:=FileAge(Source);
  209.     time:=FileDateToDateTime(ftime);
  210.     if GetTimeZoneInformation(tz)=-1 then dt:=0 else dt:=tz.bias/1440;
  211.     utime:=round(SecsPerDay*(time+dt-25569));
  212.     outFile := gzopen (Destination,outmode,s,utime);
  213.     if (outFile = NIL) then begin
  214.       raise EGZipError.Create ('Error opening '+Destination);
  215.       close(infile);
  216.       end
  217.     else begin
  218.       errorcode := gz_compress(infile, outFile);
  219.       if errorcode > 0 then begin
  220.         case errorcode of
  221.         1 : raise EGZipError.Create ('Error reading from '+Source);
  222.         2 : raise EGZipError.Create ('Error writing to '+Destination);
  223.           end;
  224.         end
  225.       else begin
  226.         if (gzclose (outFile) <> 0{Z_OK}) then
  227.            raise EGZipError.Create ('Error closing '+Destination);
  228.         (* set time stamp of gz-file *)
  229.         Handle := FileOpen(Destination, fmOpenWrite);
  230.         FileSetDate(Handle,ftime);
  231.         FileClose(Handle);
  232.         end;
  233.       end;
  234.   except
  235.     on EInOutError do
  236.       raise EGZipError.Create ('Error opening '+Source);
  237.     end;
  238.   end;
  239.  
  240. { GUnzip ------------------------------------------------------}
  241. procedure Gunzip (Source,Destination : string);
  242. var
  243.   infile     : gzFile;
  244.   outfile, f : file;
  245.   errorcode : integer;
  246.   fsize     : longword;
  247.   s         : string;
  248.   dt        : TDateTime;
  249.   ftime,
  250.   utime     : cardinal;
  251.   tz        : TIME_ZONE_INFORMATION;
  252.   Handle    : Integer;
  253. begin
  254.   AssignFile( f, Source);
  255.   try
  256.     FileMode:=0;
  257.     Reset( f, 1);
  258.     FileMode:=2;
  259.     fsize := FileSize( f);
  260.     Close( f);
  261.     infile := gzopen (Source, 'r',s,utime);
  262.     if (infile = NIL) then begin
  263.       raise EGZipError.Create ('Error opening '+Destination);
  264.       end
  265.     else begin
  266.       if length(s)>0 then s:=Destination+s
  267.       else s:=Destination+ChangeFileExt(ExtractFilename(Source),'');
  268.       AssignFile (outfile, s);
  269.       try
  270.         Rewrite (outfile,1);
  271.         s:=Destination+ChangeFileExt(ExtractFilename(Source),'');
  272.         errorcode:=gz_uncompress (infile, outfile, fsize);
  273.         if errorcode>0 then begin
  274.           case errorcode of
  275.           1 : raise EGZipError.Create ('Error reading from '+Source);
  276.           2 : raise EGZipError.Create ('Error writing to '+Destination);
  277.             end;
  278.           end
  279.         else begin
  280.           (* set time stamp of gz-file *)
  281.           if GetTimeZoneInformation(tz)=-1 then dt:=0 else dt:=tz.bias/1440;
  282.           ftime:=DateTimeToFileDate(utime/SecsPerDay-dt+25569);
  283.           Handle := FileOpen(s, fmOpenWrite);
  284.           FileSetDate(Handle,ftime);
  285.           FileClose(Handle);
  286.           end;
  287.       except
  288.         on EInOutError do
  289.             raise EGZipError.Create ('Error opening '+Destination);
  290.         end;
  291.       end
  292.   except
  293.     on EInOutError do
  294.       raise EGZipError.Create ('Error opening '+Source);
  295.     end;
  296.   end;
  297.  
  298. { MakeZip -----------------------------------------------------
  299.   Open archive for AddZip
  300. ---------------------------------------------------------------}
  301. procedure MakeZip (Destination,BasicDirectory : string);
  302. var
  303.   f : file;
  304. begin
  305.   FileList:=TStringList.Create;
  306.   FileList.Sorted:=false;
  307.   PDest:=Destination; PBase:=BasicDirectory;
  308.   AssignFile (f,Destination);
  309.   ReWrite (f,1);
  310.   CloseFile (f);
  311.   end;
  312.  
  313. { AddZip ---JR--------------------------------------------------
  314.   Add "Source" to open archive (see MakeZip)
  315. ---------------------------------------------------------------}
  316. procedure AddZip (Source : string);
  317. var
  318.   outmode   : string;
  319.   s         : string;
  320.   outFile   : gzFile;
  321.   infile    : file;
  322.   ioerr     : integer;
  323.   errorcode : integer;
  324.   size      : cardinal;
  325.   utime     : cardinal;
  326.   Header    : TPkHeader;
  327. begin
  328.   if length (PDest)>0 then begin
  329.     AssignFile (infile, Source);
  330.     try
  331.       FileMode:=0;
  332.       Reset (infile,1);
  333.       FileMode:=2;
  334.       size:=filesize(infile);
  335.       case CType of
  336.          ctHuffmanOnly : outmode:='h';
  337.          ctFiltered    : outmode:='f';
  338.         end;
  339.       outmode := outmode+copy(IntToStr(cLevel),1,1);
  340.       s:=ExtractRelativePath(PBase,Source);
  341.       utime:=FileAge(Source);
  342.       outFile := ZipOpen (PDest, outmode,s,utime);
  343.       if (outFile = NIL) then begin
  344.         raise EGZipError.Create ('Error opening '+PDest);
  345.         close(infile);
  346.         end
  347.       else begin
  348.         errorcode := gz_compress(infile, outFile);
  349.         if errorcode > 0 then begin
  350.           case errorcode of
  351.           1 : raise EGZipError.Create ('Error reading from '+Source);
  352.           2 : raise EGZipError.Create ('Error writing to '+PDest);
  353.             end;
  354.           end
  355.         else begin
  356.           if ZipClose(outfile)<>0 then begin
  357.             raise EGZipError.Create ('Error closing '+PDest);
  358.             end
  359.           else begin
  360.             Header:=TPkHeader.Create;
  361.             with outfile^ do begin
  362.               Header.Timestamp:=time;
  363.               Header.CRC:=CRC;
  364.               Header.CSize:=CSize;
  365.               Header.USize:=USize;
  366.               Header.Attr:=FileGetAttr(Source);
  367.               Header.Offset:=filepos;
  368.               end;
  369.             FreeMem(outfile,sizeof(gz_stream));
  370.             FileList.Addobject(s,Header);
  371.             end;
  372.           end;
  373.         end;
  374.     except
  375.       on EInOutError do
  376.         raise EGZipError.Create ('Error opening '+Source);
  377.       end;
  378.     end;
  379.   end;
  380.  
  381. { CloseZip -----------------------------------------------------
  382.   Write directory and final block
  383. ---------------------------------------------------------------}
  384. procedure CloseZip;
  385. var
  386.   f : file;
  387.   pke : TPkEndHeader;
  388.   pkd : TPkDirHeader;
  389.   off : cardinal;
  390.   i   : integer;
  391.   s   : string[255];
  392. begin
  393.   if length (PDest)>0 then begin
  394.     AssignFile (f,PDest);
  395.     reset (f,1);
  396.     off:=filesize(f); seek (f,off);
  397.     with FileList do for i:=0 to Count-1 do begin
  398.       with pkd do begin
  399.         Signatur:=PkDirSignatur;
  400.         VersMade:=$14;
  401.         VersExtr:=$14;
  402.         Flag:=2;
  403.         Method:=8;
  404.         FTimeStamp:=(Objects[i] as TPkHeader).TimeStamp;
  405.         CRC:=(Objects[i] as TPkHeader).CRC;
  406.         CSize:=(Objects[i] as TPkHeader).CSize;
  407.         USize:=(Objects[i] as TPkHeader).USize;
  408.         FNLength:=length(Strings[i]);
  409.         ExtraLength:=0;
  410.         CommLength:=0;
  411.         DiskStart:=0;
  412.         IntAttr:=0;
  413.         ExtAttr:=(Objects[i] as TPkHeader).Attr;
  414.         Offset:=(Objects[i] as TPkHeader).Offset;
  415.         end;
  416.       blockwrite (f,pkd,sizeof(pkd));
  417.       s:=Strings[i];
  418.       blockwrite (f,s[1],pkd.FNLength);
  419.       end;
  420.     with pke do begin
  421.       Signatur:=PkEndSignatur;
  422.       ThisDisk:=0;
  423.       StartDisk:=0;
  424.       ThisEntries:=FileList.Count;
  425.       TotalEntries:=FileList.Count;
  426.       DirSize:=filepos(f)-off;
  427.       Offset:=off;
  428.       CommLength:=0;
  429.       end;
  430.     blockwrite (f,pke,sizeof(pke));
  431.     CloseFile (f);
  432.     FileList.Free;
  433.     PDest:='';
  434.     end;
  435.   end;
  436.  
  437. begin
  438.   PDest:=''; PBase:='';
  439.   CLevel:=6; CType:=ctStandard;
  440.   end.