unit gzMain;

interface

uses
  gzio,zlib,Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, StdCtrls,libtar, ToolWin, ComCtrls,ShellAPI,FileCtrl, Spin;

var

    FTarWriter : TTarWriter;

    function gz_compress (var infile:file; outfile:gzFile): integer;

    
implementation

uses question, Overwrite, Ana_Unite;
//type
    //TCompressionType = (Standard,Filtered,HuffmanOnly);
  //  THeader = set of (zfilename, zcomment);
const
     //BUFLEN = 16384;
     FWindowOnError : boolean = false;
     //FCompressionType : TCompressionType = standard;
     //FFileDestination: String ='';
     //FDeleteSource: boolean = false;
     FProgressStep : integer = 1;
     //FComments :String= 'www.zlib.org';
//               ASCII_FLAG  = $01; { bit 0 set: file probably ascii text }
//               HEAD_CRC    = $02; { bit 1 set: header CRC present }
//               EXTRA_FIELD = $04; { bit 2 set: extra field present }
//               ORIG_NAME   = $08; { bit 3 set: original file name present }
//               COMMENT_    = $10; { bit 4 set: file comment present }
//               RESERVED    = $E0; { bits 5..7: reserved }

var
   //FGzipHeader : THeader;
   //FCompressionLevel,
   FProgress,Progress: integer;
   //FGzipFilename : string;
   //FGzipComments : string;
 gmrOverwrite: TModalResult;


procedure DoOnProgress;
begin
     Application.processmessages;

end;

function getGzipInfo (var FFileSource,FGzipFilename,FGzipComments: string): integer;
// todo: check for eof, corrupt files etc etc
var len, dummy: uInt;
	infile : file;
	head : array[0..9] of byte;
	ch : char;
	str : string;
	errorcode, ioerr : integer;
begin
   errorcode := 0;
   // Clean up old values
   FGzipFilename := '';
   FGzipComments := '';
   AssignFile( infile, FFileSource);
   {$I-}
   Reset (infile,1);
   {$I+}
   ioerr := IOResult;
   if (ioerr <> 0) then begin
	  if FWindowOnError then
		 MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0);
	  errorcode := 1
   end else begin
	  TRY
		 blockRead( infile, head, 10, len);
		 if (head[0] <> $1F) or (head[1] <> $8B) or (len<10) then begin
			// Not a Gzip-file or header not valid
			errorcode := 2;
			abort
		 end;
		 if (head[2] <> Z_DEFLATED) or ((head[3] and RESERVED) <> 0) then begin
			// Can not handle this
			errorcode := 3;
			abort
		 end;
		 if ((head[3] and EXTRA_FIELD) <> 0) then begin
			// the extra field
			blockRead(infile, len, 1);
			blockread(infile, dummy, 1);
			len := len + (dummy shl 8);
			if FileSize( infile) < int(len+12) then begin
			   errorcode := 2;
			   abort
			end;
			seek( infile, len + 12) 		// just throw it away
		 end;
		 if ((head[3] and ORIG_NAME) <> 0) then begin
			// the original file name
			str := '';
			blockread( infile, ch, 1);
			while (ch <> char(0)) and not eof( infile) do begin
			   str := str + ch;
			   blockread( infile, ch, 1)
			end;
			if eof( infile) then begin
			   errorcode := 2;
			   abort
			end;
			FGzipFilename := str
		 end;
		 if ((head[3] and COMMENT_) <> 0) then begin
			// the comments
			str := '';
			blockread( infile, ch, 1);
			while (ch <> char(0)) and not eof( infile) do begin
			   str := str + ch;
			   blockread( infile, ch, 1)
			end;
			if eof( infile) then begin
			   errorcode := 2;
			   abort
			end;
			FGzipComments := str
		 end
	  FINALLY
		CloseFile ( infile)
	  end
   end;
   getGzipInfo := errorcode
end;


{ Gzip ---------------------------------------------------------
# Returns 0 - File compressed
#         1 - Could not open FFileIn
#         2 - Could not create FFileOut
#      >100 - Error-100 in gz_compress
---------------------------------------------------------------}
{ 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
# 3 - gzclose error
-----------------------------------------------------------}
function gz_compress (var infile:file; outfile:gzFile): integer;
var
  len   : uInt;
  ioerr : integer;
  buf  : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack }
  errorcode : byte;
  fsize, lensize : DWord;
(*{$IFDEF VER100, VER90}
  fsize, lensize : DWord;
{$ELSE}
       fsize, lensize : LongWord;
{$ENDIF} *)
begin
  errorcode := 0;
  Progress := 0;
  fsize := FileSize(infile);
  lensize := 0;
  if FProgressStep > 0 then DoOnProgress;

  AnaForm.UploadProgressBar.Max := fsize;
  AnaForm.UploadProgressBar.Position := 0;
  while true do begin

	{$I-}
	blockread (infile, buf, Z_BUFSIZE, 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;
	if FProgressStep > 0 then begin
	   {$WARNINGS OFF}{Calculate progress and raise event}
	   lensize := lensize + len;
	   if ((lensize / fsize) * 100 >= FProgress + FProgressStep)
						or (lensize = fsize) then begin
		  FProgress := Trunc((lensize / fsize) * 100);
		  DoOnProgress;

      AnaForm.UploadProgressBar.Position := lensize;
      Application.ProcessMessages;
      
	   end
	   {$WARNINGS ON}
	end
  end; {WHILE}

  closeFile (infile);
  if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3;

  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
# 3 - gzclose Error
-----------------------------------------------------------}
function gz_uncompress (infile:gzFile; var outfile:file;fsize:DWord{LongWord}) : integer;
var
  len     : integer;
  written : uInt;
  buf  : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack }
  errorcode : byte;
  lensize : DWord{LongWord};
begin
  errorcode := 0;
  FProgress := 0;
  lensize := 0;
  if FProgressStep > 0 then DoOnProgress;
  while true do begin
	len := gzread (infile, @buf, Z_BUFSIZE);
	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;
	if FProgressStep > 0 then begin
	   {$WARNINGS OFF}
	   lensize := lensize + len;
	   if ((lensize / fsize) * 100 >= FProgress + FProgressStep)
						or (lensize = fsize) then begin
		  FProgress := Trunc((lensize / fsize) * 100);
		  DoOnProgress
	   end
	   {$WARNINGS ON}
	end
  end; {WHILE}
  if (gzclose (infile) <> 0{Z_OK}) then begin
	 if FWindowOnError then
		MessageDlg('gzclose Error.', mtError, [mbAbort], 0);
	 errorcode := 3
  end;
  gz_uncompress := errorcode
end;



function Gunzip (var FFileSource,FFileDestination: string): integer;
var
	infile : gzFile;
	outfile : file;
	ioerr : integer;
	errorcode : integer;
	fsize : DWord{LongWord};
	s : gz_streamp;
begin
  errorcode := 0;

  infile := gzopenZ (FFileSource, 'r', 0);
  if (infile = NIL) then begin
	if FWindowOnError then
	   MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0);
	errorcode := 1
  end
  else begin
	s := gz_streamp(infile);
	fsize := FileSize( s^.gzfile);

	AssignFile (outfile, FFileDestination);
	{$I-}
	Rewrite (outfile,1);
	{$I+}
	ioerr := IOResult;
	if (ioerr <> 0) then begin
		if FWindowOnError then
		   MessageDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0);
		errorcode := 2
	end
	else begin
		{ We could open all files, so time for uncompressing }
		gz_uncompress (infile, outfile, fsize);
		//if FDeleteSource then DeleteFile(FFileSource);
	   {$I-}
	   close (outfile);
	   {$I+}
	   ioerr := IOResult;
	   if (ioerr <> 0) then begin
		  if FWindowOnError then
			 MessageDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0);
		  halt(1)
	   end
	end
  end;

  Gunzip := errorcode
end;

procedure GZipFile(lSourceFile: String; lMulti: boolean);
var
  //FGzipHeader : THeader;
  //FCompressionLevel,FProgress,Progress: integer;
  FGzipFilename : string;
  FGzipComments : string;
  outmode : string;
	s,FFileDestination : string;
	infile  : file;
	outfile : gzFile;
	FCompressionLevel{,errorcode} : integer;
	flags : uInt;
	stream : gz_streamp;
	p : PChar;
  lProceed: TModalResult;
	ioerr : integer;

begin
//FGzipHeader := [zFilename];
FGzipFilename:= lSourceFile;
FGzipComments := '';
FProgress := 0;
//FCompressionLevel := MainForm.CompressEdit.value;
if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6;
//MainForm.ProgressBar1.position :=1;
//Gzip (lFile,lMulti);
//MainForm.ProgressBar1.position := 0;
 FFileDestination := lSourceFile+'.gz';
 //result := 2; //return error if user aborts
 if fileexists(FFileDestination) then begin
    if lMulti then begin
       if (gmrOverwrite = mrYes) or (gmrOverwrite = mrNo) then begin
          OverwriteForm.Label1.caption := 'Warning: the file '+FFileDestination+' already exists.';
          gmrOverwrite := OverwriteForm.Showmodal;
       end;
       lProceed := gmrOverwrite;
       if (lProceed = mrNo) or (lProceed = mrNoToAll) then exit;
    end else begin
        case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of	{ produce the message dialog box }
             id_Abort: exit;
        end;
    end; //not multi
 end;
  AssignFile (infile, lSourceFile);
  {$I-}
  Reset (infile,1);
  {$I+}
  ioerr := IOResult;
  if (ioerr <> 0) then begin
	if FWindowOnError then
		 MessageDlg('Can''t open: '+lSourceFile, mtError, [mbAbort], 0);
	//errorcode := 1
  end
  else begin
	  outmode := 'w  ';
	  s := IntToStr(FCompressionLevel);
	  outmode[2] := s[1];
          outmode[3] := ' ';
	  (*case FCompressionType of
		   Standard    : outmode[3] := ' ';
		   HuffmanOnly : outmode[3] := 'h';
		   Filtered    : outmode[3] := 'f';
	  end;*)

	  //flags := 0;
	  //if (zfilename in FGzipHeader) then
          flags := ORIG_NAME;
	  //if (comment  in FGzipHeader) then flags := flags + COMMENT_;
	  outfile := gzopenZ ({FFileDestination}lSourceFile, outmode, flags);
	  if (outfile = NIL) then begin
		 if FWindowOnError then
			  MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0);
		 close( infile);
		 //errorcode := 2
                 exit;
	  end
	  else begin
		 { if flags are set then write them }
		 stream := gz_streamp(outfile);
		 if {(zfilename in FGzipHeader)} true then begin
                        s := ExtractFilename(lSourceFile);
			p := PChar(s);
			blockWrite( stream^.gzfile, p[0], length(s)+1);
			stream^.startpos := stream^.startpos + length(s) + 1
		 end;
		 {if (zcomment  in FGzipHeader) then begin
			p := PChar(FGzipComments);
			blockWrite( stream^.gzfile, p[0], length(FGzipComments)+1);
			stream^.startpos := stream^.startpos + length(FGzipComments) + 1
		 end;
		 { start compressing }
		 {errorcode :=} gz_compress(infile, outfile);
		 {if errorcode <> 0 then errorcode := errorcode+100
		 else
			if FDeleteSource then erase (infile);}
	  end
   end;
//   MainForm.ProgressBar1.position := 0;
end;

function isTGZ (var lStr: string): boolean;
var lExt: string;
begin
   lExt := extractfileext(lStr);
   lExt := UpperCase(lExt);
   if (lExt='.TGZ') then
      Result := true
   else
       Result := false;
end;

function GunzipFile (var lFile,FFileDestination: string):  boolean;
var FGzipFilename,FGzipComments: string;
begin
     result := false;
     FProgress := 0;
     FGzipFilename := '';
     getGzipInfo(lFIle,FGzipFilename,FGzipComments);
     if FGzipFilename <> '' then
        FFileDestination :=  extractfilepath(lFIle)+FGzipFilename
     else if (isTGZ(lFile)) then
         FFileDestination := changefileext(lFile,'.tar')
     else
         FFileDestination := changefileext(lFile,'');
     //FFileDestination := changefileext(lFile,'.stop');//abort tgz after gz decompress
     if fileexists(FFileDestination) then begin
        case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,
             [mbYes, mbAbort], 0) of
             id_Abort: exit;
        end;//case
     end; //fileexists
//    MainForm.ProgressBar1.position :=1;
    gunzip (lFIle,FFileDestination);
//    MainForm.ProgressBar1.position := 0;
    result := true;
end;

function StrOut(var lInStr: String; lStartPos: integer): string;
var lInc,lLen: integer;
begin
    result := '';
    lLen := length(lInStr);
    if lLen <= lStartPos then exit;
    for lInc := lStartPos to lLen do
        result := result+lInStr[lInc];
end;

procedure AddDirTar(lStr: string; var lDirLen: integer {base dur});
var
 lFullname,lName,lNewDir: String;
 lSearchRec: TSearchRec;
begin
 lNewDir := lStr+'\';
 if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin
    repeat
      lFullname := lNewDir+lSearchRec.Name;
      lName := AnsiUpperCase(lSearchRec.Name);
      if  (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin
           if (DirectoryExists(lFullname)) then
              AddDirTar(lFullName,lDirLen) //change
           else begin
             FTarWriter.AddFile (lFullname,StrOut(lFullname,lDirLen));
           end;
      end; //not '..' or '.'
    until FindNext(lSearchRec) <> 0;
 end;
 FindClose(lSearchRec);
end;


procedure E (var lTarFile: string); //extract target
VAR
  TA        : TTarArchive;
  DirRec    : TTarDirRec;
  lProceed : TModalResult;
  lPos,lLen,lnumFilesTotal,lnumFilesCompleted,lPct: longint;
  lStr,lOutDir,lLocalDir,lFileName,lNewDir,lTarName : String;
begin
            lOutDir := extractfiledir(lTarFile);
            //next Count files for progress bar....
            lnumFilesTotal := 0;
            TA := TTarArchive.Create (lTarFile);
            TRY
               TA.Reset;
               TA.SetFilePos (0);
               TA.FindNext (DirRec);
               repeat
                     inc(lnumFilesTotal);
               until not TA.FindNext (DirRec);
            FINALLY
                   TA.Free;
            END;
            //finished counting files
            //next: extract files...
            lnumFilesCompleted := 0;
            FProgress := 0;
            TA := TTarArchive.Create (lTarFile);
            TRY
               TA.Reset;
               TA.SetFilePos (0);
               TA.FindNext (DirRec);
            repeat
              inc(lNumFilesCompleted);
              lPct := round(lNumFilesCOmpleted/lNumfilesTotal*100);
              if lPct > FProgress then begin //only update progress bar 100 times: do not waste time updating screen
                 FProgress := lPct;
                 DoOnProgress;
              end;
              if DirRec.Name <> '' then begin
               Screen.Cursor := crHourGlass;
               TRY
                  //filename change '/' to '\'
                  lTarName := '';
                  lLen := length(DirRec.name);
                  for lPos := 1 to lLen do begin
                     if (DirRec.Name[lPos]='/') then
                        lTarName := lTarName + '\'
                     else if (DirRec.Name[lPos]=':') then

                     else
                         lTarName := lTarName + DirRec.Name[lPos];
                  end;
                  lFilename := lOutDir+'\'+lTarName;
                  lLocalDir := extractfiledir(lFileName);
                  if (DirectoryExists(lLocalDir)) then begin
                    lProceed := mrYes;
                    if Fileexists(lFileName) then begin
                       if (gmrOverwrite = mrYes) or (gmrOverwrite = mrNo) then begin
                          OverwriteForm.Label1.caption := 'Warning: the file '+lFilename+' already exists.';
                          gmrOverwrite := OverwriteForm.Showmodal;
                       end;
                       lProceed := gmrOverwrite;
                    end;
                    if (lProceed = mrYes) or (lProceed = mrYesToAll) then begin
                     if (lFilename[length(lFilename)] = {'/'}'\') and (length(lFilename)>1) then begin
                        lLen := length(lFilename)-1;
                        lStr := lFilename;
                        lFilename := '';
                        for lPos := 1 to lLen do
                            lFilename := lFilename+lStr[lPos];
                        if not directoryexists(lFilename) then begin
                           mkdir (lFilename);
                        end;
                     end else
                         TA.ReadFile (lFileName);
                    end; //proceed
                  end else begin
                     lLen := length(lTarName);
                     lPos := 1;
                     if (lLen >= 1) and ((lTarName[1] = '\') {or (DirRec.Name[lPos] = '/')}) then inc(lPos);
                     lNewDir := lOutDir+'\';
                     while lPos <= lLen do begin
                          if (lTarName[lPos] = '\') or (lTarName[lPos] = '/') then begin
                             //showmessage('creating directory:'+lNewDir);
                             if not directoryexists(lNewDir) then
                                mkdir(lNewDir);
                             lNewDir := lNewDir + '\';
                          end else
                           lNewDir := lNewDir + lTarName[lPos];
                          inc(lPos);
                     end;
                     if (lFileName[length(lFileName)] <> '\') and  (DirectoryExists(lLocalDir)) and (not Fileexists(lFileName)) then begin
                        TA.ReadFile (lFileName)
                     end; (**)
                  end;
               FINALLY
                      Screen.Cursor := crDefault;
               END;
              end;
            until not TA.FindNext (DirRec);
            FINALLY
                   TA.Free;
            END;
//            MainForm.ProgressBar1.position := 0;
end;

function isGZ (var lStr: string): boolean;
var lExt: string;
begin
   lExt := extractfileext(lStr);
   lExt := UpperCase(lExt);
   if  (lExt='.GZ') or (lExt='.TGZ') then
      Result := true
   else
       Result := false;

end;

function isTar (var lStr: string): boolean;
var lExt: string;
begin
   lExt := extractfileext(lStr);
   lExt := UpperCase(lExt);
   if   (lExt='.TAR') then
      Result := true
   else
       Result := false;

end;

procedure GZRecursive (lFullname: string);
var
 lNewDir,lNewName: String;
 lSearchRec: TSearchRec;
begin
 if not DirectoryExists(lFullname) then begin
    lNewName := lFullname;
    if isGZ(lNewName) then exit;
    GZipFile(lNewName,true);
    exit;
 end;
 lNewDir := lFullname+'\';
 if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin
    repeat
      lNewName := lNewDir+lSearchRec.Name;
      if  (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then
            GZRecursive(lNewName);
    until (FindNext(lSearchRec) <> 0);
 end;
 FindClose(lSearchRec);
end;



procedure ExtractRecursive (lFullname: string);
var
 lNewDir,lNewName,FFileDestination: String;
 lGunZip: boolean;
 lSearchRec: TSearchRec;
begin
 if not DirectoryExists(lFullname) then begin

    lNewName := lFullname;
    lGunzip := false;
    if isGZ(lNewName) then begin
       lGunzip := true;
       if not GunzipFile (lNewName,FFileDestination) then exit;
       lNewName := FFileDestination;
    end;
    if isTAR(lNewName) then begin
       E(lNewName);
       if lGunzip then deletefile(FFileDestination);
    end;
    exit;
 end;
 lNewDir := lFullname+'\';
 if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin
    repeat
      lNewName := lNewDir+lSearchRec.Name;
      if  (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then
            ExtractRecursive(lNewName);
    until (FindNext(lSearchRec) <> 0);
 end;
 FindClose(lSearchRec);
end;

const
 kArchive = 1;
 kNotArchive = 2;
 kMixed = 3;
 g1stFile: boolean = true;
 gnFilesNotDir: longint = 0;

function ExtType (var lStr: string): integer;
var lExt: string;
begin
   lExt := extractfileext(lStr);
   lExt := UpperCase(lExt);
   if (lExt = '.TAR') or (lExt='.GZ') or (lExt='.TGZ') then
      Result := kArchive
   else
       Result := kNotArchive;

end;

procedure CheckExtType(lFullname: string; var lExtType: integer);  //recursive check
var
 lNewDir,lNewName: String;
 //lType: integer;
 lSearchRec: TSearchRec;
begin
 if not DirectoryExists(lFullname) then begin
//xx    inc(gnFilesNotDir);
    if g1stFile then begin
       lExtType := ExtType(lFullName);
//xx       g1stFile := false;
    end else
        if ExtType(lFullName) <> lExtType then
           lExtType := kMixed;
    exit;
 end;
 lNewDir := lFullname+'\';
 if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin
    repeat
      lNewName := lNewDir+lSearchRec.Name;
      if  (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin
          CheckExtType(lNewName,lExtType);
      end;
    until (FindNext(lSearchRec) <> 0) or (lExtType = kMixed);
 end;
 FindClose(lSearchRec);
end;



procedure WMDropFiles(var Msg: TWMDropFiles); //message WM_DropFiles;
var
lInc: integer;
CFilename: array [0..MAX_Path] of Char;
lStringList: TStringList;
begin
 lStringList := TStringList.Create;
 try
  lInc := 0;
  while DragQueryFile(Msg.Drop,lInc,CFilename,Max_Path) > 0 do begin
       inc(lInc);
       lStringList.Add(CFilename);
       Msg.Result := 0;
   end;//while
  finally
   DragFinish(Msg.Drop);
  end; //try
  if lStringList.Count > 0 then
//   ProcessStringList(lStringList);
  lStringList.Free;
 end;

procedure CreateTar;
begin
//  IF DlgTar.Filename = '' THEN BEGIN
//    ShowMessage ('Please enter the TAR file''s name first');
//    EXIT;
//  END;
  FTarWriter.Free;
  FTarWriter := nil;
//  FTarWriter := TTarWriter.Create (DlgTar.Filename);
end;


procedure FormHide(Sender: TObject);
begin
//      FreeAndNil (FTarWriter);
  FTarWriter.Free;
  FTarWriter := nil;

end;



end.
