unit ghpacku;{for dll compress}
{$I define.pas}

{$define timestamp}

interface
uses
  {$IFNDEF WINDOWS}
  Dos,
  {$ELSE}
  SysUtils,
  {$ENDIF}
  {txt,}
  TVType, MyType, Objects, Stru, MyLib, Fileu,
  LogType, LangType,
  StrStrm, Stack, {scanfils, }Errors,
 {$IFDEF USEDLL}
  MsgProc, LogProc, LangProc,
  {langtype, langproc, txgh}
 {$ELSE}
  Msgu, Logu, Country, {syslog}
 {$ENDIF}
  Streams, ForEach, {Lzh, }
  LHArcu
  {$IFDEF LDOS}
  ,ldos
  {$ENDIF}

{$IFDEF DEBOPENFILE}
  ,openfile
{$ENDIF}
  ;

const
  GHPackExt = '.GHP';

type

  PArchive = ^TArchive;
  TArchive = object (TObject) {descendant of TBufStream}
    {object for adding and extracting files to and from archive file (see TStorage)}
    Stream:PMBufStream;
    ArchiveName:string;

    SourceDir:string;
    TempDir:string;
    DefProgBox:pointer;
    SizeToDo:longint;
    SizeDone:longint;
    ResultCode:integer;

    CONSTRUCTOR Init(AFileName : string; AMode, ASize : WORD);

    function AddFile(AFileName : PathStr): LongInt; {appends file to the end of the file storage file}
    function ExtractFile(AFileName : PathStr; OutDir: PathStr): boolean;
       {if AFileName = '', extracts next file to outdir }
    function ExtractNextFile(OutDir : DirStr; ToWrite: boolean): PathStr;

    procedure InstallFiles(OutDir : DirStr);

    destructor Done;virtual;
    procedure SetSourceDir(ADir:string);

    function GetTempName:string;
    procedure Seek(APos:longint);
    function GetSize:longint;
    procedure SetSizeToDo(ASizeToDo:longint);
  end;

const
  ReadMeFileName = 'READ.ME';
  DoubleCompress : boolean = true;

  coCreate = 1;
  coAppend = 2;
  coRecursive = 4;

{replacable by makeinst:}
  InstallName : string12 = 'INSTALL.EXE';
  GDataFile: string12 = 'DATAFILE.001';
  DiskettesStr: string12 = 'DISKETTESXXX';
  DiskSpaceStr: string12 = 'DISKSPACEXXX';


{procedure MakeInstallFile(DataFile:PathStr);}
{create archive file datafile from all files in current dir,
 if file READ.ME is present, is archived 1st (for fast access in install program)}

{procedure Install(DataFile:PathStr; OutDir: DirStr);}
{extrats all file from datafile to directory OutDir}


function CompressFiles(SourceFiles:string; ArchiveName:string; Options:word):integer;{$IFDEF PMODE}export;{$ENDIF}
function DecompressFiles(ArchiveName:string; DestDir:string):integer;{$IFDEF PMODE}export;{$ENDIF}

{$IFDEF TEST}
procedure Test;
{$ENDIF}

implementation

const
  maxbuflen = 65530;
  TempName = 'LZTEMP.$$';

type

  TFileHeader = record
    case integer of
      0:(
         HeaderSize:word;{for the case it will change}
         FSize:longint;
         FTime:longint;
         FComprSize:longint;{for control}
         FNameLen:byte;
        );
      1:(HeadSize:word;
         Data:array[0..12] of byte;)
  end;

CONSTRUCTOR TArchive.Init(AFileName : string; AMode, ASize : WORD);
begin
  if not Inherited Init then
    Fail;
  ArchiveName := ReplaceExt(FExpand(AFileName), GHPackExt, false);
  TempDir := GetFileDir(ArchiveName);
  DefProgBox:=pointer(DefaultProgressBox);
  SizeToDo:= 0;
  SizeDone:= 0;
  ResultCode:= 0;

  Stream := New(PMBufStream, Init(ArchiveName, AMode, ASize));
  if Stream = nil then
    Fail;
  SourceDir := '';

end;

function TArchive.AddFile(AFileName : PathStr): LongInt;
var
  S : PMBufStream;

  dir:dirstr;
  name:namestr;
  ext:extstr;

  curdir:dirstr;

  {buf : PBuffer;}
  {fnsize:byte; {size of FNameInArchive (real, i.e. 1 + length)}
  {oflen, {original length of file before eventual compression}
  {flen,  {length of file to write to storage (after eventual compression)}
  {writelen, {sum of length of file, sizeof filename and sizeof longint}
  {toread,  {how much of bytes to read from file to buffer}
  {lpos:longint; {dummy to get value from WriteMsg}

  {bufpos, buflen : word;}

  cnt:Longint;
  r:real;

  FNameInArchive:string;
  Head:TFileHeader;
  res:longint;

label ex;
begin
  res := -1;
  if AFileName = '' then begin
    SysError('Archive.AddFile Empty File Name');
    goto ex;
  end;
  AFileName := FExpand(AFileName);

  if AFileName = FExpand(GetTempName) then begin
    res := 0;
    goto ex;
  end;

  Head.HeaderSize := sizeof(TFileHeader);
  Head.FSize := GetFileSize(AFileName);
  Head.FTime := GetFileTime(AFileName);

  if (SourceDir <> '') and (pos(SourceDir, AFileName) = 1) then begin
    FNameInArchive := copy(AFileName, length(SourceDir) + 1, 255);
  end else begin
    FNameInArchive := copy(AFileName, 3, length(AFileName) - 2); {chop off drive}
  end;
  Head.FNameLen := length(FNameInArchive);

  if DoubleCompress then begin
    ProgressBox(DefProgBox, pbMsg, FNameInArchive, 0,0);
    res := CompressFile(AFileName, GetTempName);
    if res <> 0 then begin
      SysError('Archive.AddFile Compress Failed: '+ AFileName);
      goto ex;
    end;
  end else begin
    if not CopyFile(AFileName, GetTempName) then begin
      SysError('Archive.AddFile Copy File Failed: ' + AFileName);
      goto ex;
    end;
  end;
  Head.FComprSize := GetFileSize(GetTempName);

  S := New(PMBufStream, Init(GetTempName, stOpenRead, 1024));
  if (S = nil) then begin
    SysError('Archive.AddFile Open ' + GetTempName + ' failed.');
    goto ex;
  end;
  if S^.Status = stOK then begin
    Stream^.Write(Head, sizeof(Head));
    Stream^.Write(FNameInArchive[1], length(FNameInArchive));
    Stream^.CopyFrom(S^, S^.GetSize);

    SizeDone := SizeDone + Head.FSize;
    ProgressBox(DefProgBox, pbUpdate, FNameInArchive, SizeDone, SizeToDo);

    if (S^.Status = stOK) and (Stream^.Status = stOK) then begin
      res := 0
    end else begin
      SysError('Archive.AddFile Read File ' + FNameInArchive + ' From Archive Failed.');
    end;
  end else begin

  end;
  Dispose(S, done);

ex:
  if ResultCode = 0 then
    ResultCode := LongRec(res).Lo;
  AddFile := res;
end;

function TArchive.ExtractFile(AFileName : PathStr; OutDir: PathStr): boolean;
var
  found : boolean;
  fname : PathStr;
  fpos : longint;
begin
  ExtractFile := false;
  OutDir := AddBackSlash(OutDir);

  if AFileName = '' then begin
    fname := ExtractNextFile(OutDir, True);
  end else begin
    found := false;
    repeat
      fpos := Stream^.GetPos;
      fname := ExtractNextFile(OutDir, false);
      if SameNameAndExt(fname, AFileName) then
        found := true;
    until (fname = '') or found;
    if found then begin
      Stream^.Seek(fpos);
      fname := ExtractNextFile(OutDir, True);
    end;
  end;
  if fname <> '' then begin
    ProgressBox(DefProgBox, pbMsg, fname, 0, 0);
    ExtractFile := true;
  end;
{  ProgressBox(DefProgBox, pbUpdate, '', fpos, Stream^.GetSize);}
end;

function TArchive.ExtractNextFile(OutDir : DirStr; ToWrite: boolean): PathStr;
var
  S : PMBufStream;
  fname : string;

  dir:dirstr;
  name:namestr;
  ext:extstr;
  curdir:dirstr;

  all:longint;
  fpos :longint;
  Head:TFileHeader;
  res:integer;

label ex;

begin
  ExtractNextFile := '';
  S := nil;
  fpos := Stream^.GetPos;
  res := 0;

  if fpos = Stream^.GetSize then
    exit;
  Stream^.Read(Head.HeaderSize, sizeof(Head.HeaderSize));
  Stream^.Read(Head.Data, Head.HeaderSize - sizeof(Head.HeaderSize));
  Stream^.Read(fname[1], Head.FNameLen);
  fname[0] := chr(Head.FNameLen);

  FSplit(fname, dir, name, ext);
  fname := name + ext;

  if ToWrite then begin
    OutDir := AddBackSlash(OutDir);
    if (dir <> '') and (dir[1] <> '\') then begin
      fname := dir + fname;
      if not CreateDir(OutDir + dir) then begin
        SysError('Archive.Extract Create Dir ' + OutDir + dir + ' Failed.');
        res := -1;
        goto ex;
      end;
    end;
      {OutDir := OutDir + dir;}
    S := new(PMBufStream, Init(GetTempName{OutDir + fname}, stCreate, 1024));
    if S = nil then begin
      SysError('Archive.Extract Create File ' + GetTempName + ' Failed.');
      res := -1;
      goto ex;
    end;
    if S^.Status <> 0 then begin
      SysError('Archive.Extract: Create File ' + GetTempName + ' Failed.');
      res := -1;
      goto ex;
    end;
    S^.CopyFrom(Stream^, Head.FComprSize);
    if (S^.Status = stOK) {and (Stream^.Status = stOK)} then begin
      FreeObject(@S);
      ProgressBox(DefProgBox, pbMsg, OutDir + fname, 0, 0);

      if DoubleCompress then begin
        if DecompressFile(GetTempName, OutDir + fname) = 0 then
          ExtractNextFile := fname;
      end else begin
        if CopyFile(GetTempName, OutDir + fname) then
          ExtractNextFile := fname;
      end;
      SetFileTime(OutDir + fname, Head.FTime);
    end else begin
      SysError('Archive.Extract: Error reading stream ' + GetTempName + '.');
      res := -1;
      FreeObject(@S);
    end;
    {ProgressBox(DefProgBox, pbMsg, fname, 0, 0);}
    ProgressBox(DefProgBox, pbUpdate, fname, Stream^.GetPos, Stream^.GetSize);
  end else begin
    Stream^.Seek(Stream^.GetPos + Head.FComprSize);
    if Stream^.Status = stOK then
      ExtractNextFile := fname;
  end;

ex:
  if ResultCode = 0 then
    ResultCode := res;
{  FreeMem(buf, buflen); done in storage}
end;

procedure TArchive.InstallFiles(OutDir : DirStr);
var
  p : record
    s: PString;
  end;
begin
  if not DirExists(OutDir) then begin
    if not CreateDir(OutDir) then begin
      p.s := @OutDir;
      ShowMessage(gettxt(txCannotCreateDir) +' ' + OutDir, smError, 0);
      exit;
    end;
  end;
  repeat
    ProgressBox(DefProgBox, pbUpdate, '',Stream^.Getpos, Stream^.GetSize);
  until not ExtractFile('', OutDir);
{      writeln('End of file or no such file found');}
end;

procedure TArchive.SetSourceDir(ADir:string);
begin
  SourceDir := AddBackSlash(ADir);
end;

function TArchive.GetTempName:string;
begin
  GetTempName := TempDir + TempName;
end;

procedure TArchive.Seek(APos:longint);
begin
  if Stream <> nil then
    Stream^.Seek(APos);
end;

function TArchive.GetSize:longint;
begin
  GetSize := 0;
  if Stream <> nil then
    GetSize := Stream^.GetSize;
end;

procedure TArchive.SetSizeToDo(ASizeToDo:longint);
begin
  SizeToDo := ASizeToDo;
  SizeDone := 0;
end;

destructor TArchive.Done;
begin
  FreeObject(@Stream);
  EraseFile(GetTempName);
  inherited Done;
end;
{/TArchive}
(*
procedure MakeInstallFile(DataFile:PathStr);

var Stor : PArchive;
    buf : PBuffer;
    i : integer;
    l: longint;
    dir : dirstr;
    base: namestr;
    ext : extstr;
    fname: PathStr;
    {$IFDEF WINDOWS}
    SR : TSearchRec;
    DosError:integer;
    {$ELSE}
    SR : SearchRec;
    {$ENDIF}


  function IsArchivName(aname:string12): boolean;
  var d:dirstr; n:namestr; e:extstr; s:string[3];r,code:integer;
  begin
    fsplit(aname,d,n,e);
    val(copy(e, 2, length(e) - 1), r, code);
    if (code <> 0) or (n <> base) then
      IsArchivName := false
    else
      IsArchivName := true;
  end;


begin
  fsplit(DataFile, dir, base, ext);
  DataFile := base + '.001';
  Stor := New (PArchive, Init(DataFile, stCreate, 1024));
  if (stor = nil) then begin
    ShowMessage(gettxt(txOutOfMemory), smError, 0);{langtype}
    exit;
  end;
  if Stor^.Status <> stOK then
    exit;
  if not FExists(InstallName) then begin
    ShowMessage(gettxt(txFileNotFound) + ' ' + InstallName, smError, 0);
    exit;
  end;
  if FExists(ReadMeFileName) then begin
    l := Stor^.AddFile(ReadMeFileName);
  end;
  {$IFDEF WINDOWS}
  DosError :=
  {$ENDIF}
  FindFirst('*.*', faArchive, SR); { Same as DIR *.PAS }
  while DosError = 0 do
  begin
    if (SR.Name <> ReadMeFileName) and (not IsArchivName(SR.Name))
    and (SR.Name <> InstallName) then
      l := Stor^.AddFile(SR.Name);
    {$IFDEF WINDOWS}DosError := {$ENDIF} FindNext(SR);
  end;
  Dispose(Stor, Done);
end;


procedure Install(DataFile:PathStr; OutDir: DirStr);
var
    Stor : PArchive;
    S: PMBufStream;
    buf : PChar;
    i : integer;
begin
  Stor := New(PArchive, Init(FindUtlFile(DataFile), stOpenRead, 1024));
  if stor = nil then begin
    ShowMessage(gettxt(txFileNotFound) + DataFile, smError, 0);
    exit;
  end;
  Stor^.InstallFiles(OutDir);
  Dispose(Stor, Done);
end;

*)

const
  dfCompress = 0;
  dfDecompress = 1;

function DoFiles(SourceFiles:string; DestDir:String; what:integer):integer;
{source files: dir\mask (e.g. 'c:\data\*.dbf'); returns 0 on success}
var
  dir, tdir:dirstr;
  name, tname:namestr;
  ext, text:extstr;
  {$IFDEF WINDOWS}
  dirinfo:TSearchRec;
  DosError:integer;
  {$ELSE}
  dirinfo:SearchRec;
  {$ENDIF}
  res:integer;
begin
  DoFiles := 0;

  if not CreateDir(DestDir) then begin
    DoFiles := -1;
    exit;
  end;
  DestDir := AddBackSlash(DestDir);

  FSplit(SourceFiles, dir, name, ext);
  {$IFDEF WINDOWS}DosError:={$ENDIF}FindFirst(dir + name + ext, faArchive, DirInfo);
  while DosError = 0 do
  begin
    FSplit(DirInfo.Name, tdir, tname, text);
    case what of
      dfCompress:
       res := CompressFile(dir + DirInfo.Name, DestDir + tname + text{'.LZ'});
      dfDecompress:
       res := DecompressFile(dir + DirInfo.Name, DestDir + tname + text);
    end;
    if res <> 0 then begin
      DoFiles := res;
      exit;
    end;
    {$IFDEF WINDOWS}DosError := {$ENDIF}FindNext(DirInfo);
  end;
end;


{const
  BackupFileName = 'BACKUP.DAT';}
var
  DefProgBox:pointer;

function CompressFiles(SourceFiles:string; ArchiveName:string; Options:word):integer;
{source files: SourceDir\masklist (e.g. 'C:\DATA\*.dbf;*.ini;199702\*.dbf;...')
 masklist can contain subdirectory .. 199702\*.dbf
 returns 0 on success}
var
  DestDir: String;{destination dir of archive}
  ArchiveBase: String;{archive base name (without path and ext)}
  {tdir, ddir: dirstr;}
  SourceDir: String;{base source dir of files beeing added,
    used  during scanning through SourceFiles to split it off from
    full pathnames of added files }
  SourceMasks:TStringStream;{SourceFiles set to it without SourceDir,
   e.g.: 'C:\DATA\*.dbf;199702\*.dbf;..' - to SrcFiles copied: '*.dbf;199702\*.dbf;..'
   }
  recursive:boolean;

  name: string;
  ext: string;

  mask,{current mask got from the SourceMasks}
  masks: string;{temp. used to init SourceMasks}
  p : byte;{temp. used to find ';' in SourceFiles}

  {$IFDEF WINDOWS}
  {dirinfo:TSearchRec;
  DosError:integer;}
  {$ELSE}
  {dirinfo: SearchRec;}
  {$ENDIF}

  res: integer;

{  SubDirs: TStringStack;{stack}
{  subDirsCount, curSubDirNo:integer;}

  AR: PArchive;

  DoneBytes, AllBytes: longint;
  runCount:byte;

  Mode:word;

  (*
  function FindSubDirs: boolean;
  var
    {$IFDEF WINDOWS}
    DirInf:TSearchRec;
    DosError:integer;
    {$ELSE}
    DirInf:SearchRec;
    {$ENDIF}
    name:string12;
  begin
    FindSubDirs := false;
    if not SubDirs.Init(10, 5) then
      exit;
    {$IFDEF WINDOWS}DosError := {$ENDIF}
    FindFirst(SourceDir + '*.*', faDirectory, DirInf);
    while DosError = 0 do
    begin
      if DirInf.Attr = faDirectory then begin
        if pos('..',DirInf.Name) = 0 then begin
          if ((Options and coRecursive) <> 0) or (DirInf.Name = '.') then begin
            name := DirInf.Name;
            SubDirs.Push(name);
          end;
        end;
      end;
      {$IFDEF WINDOWS}DosError := {$ENDIF}FindNext(DirInf);
    end;
    FindSubDirs := true;
  end;
  *)

  function IsArchiveFile(FileName:string):boolean;
  var i:integer;
  begin
    IsArchiveFile := false;
    FileName := FExpand(FileName);
    for i := 1 to 1 do begin
      if FileName = (DestDir + ArchiveBase + '.' + lzero(IntToStr(i), 3)) then
      begin
        IsArchiveFile := true;
        exit;
      end;
    end;
  end;

  procedure AddFile(Var Dir: DirStr; Var S : SearchRec); Far;
  begin
    if res <> 0 then
      exit;
    if IsArchiveFile(Dir + S.Name) then
      exit;
    if runCount = 1 then begin
      res := AR^.AddFile(Dir + S.Name);
      if res <> 0 then
        exit;
      {inc(DoneBytes, GetFileSize(ddir + DirInfo.Name));}
      {ProgressBox(DefProgBox, pbUpdate, '', DoneBytes, AllBytes);}
    end;
    inc(DoneBytes, GetFileSize(Dir + S.Name));
  end;

const
  CaseSensitive = false;

begin
  CompressFiles := -1;
  res := 0;
  recursive := (Options and coRecursive) <> 0;

  if not CaseSensitive then begin
    SourceFiles := UsUppcase(SourceFiles);
    ArchiveName := UsUppcase(ArchiveName);{mylib}
  end;

  FSplit(FExpand(ArchiveName), DestDir, ArchiveBase, ext);

  p := pos(';', SourceFiles);
  if p > 0 then begin
    masks := copy(SourceFiles, p + 1, 255);
    SourceFiles := copy(SourceFiles, 1, p - 1);
  end else
    masks := '';
  SourceFiles := FExpand(SourceFiles);
  FSplit(SourceFiles, SourceDir, name, ext);
  masks := name + ext + ';' + masks;
  SourceMasks.Init(masks);
  SourceMasks.SetDelimitors([';']);

  if not CreateDir(DestDir) then begin
    SysError('Can not create dir ' + DestDir);
    exit;
  end;

  if (Options and coCreate) <> 0 then begin
    Mode := stCreate;
  end else begin
    Mode := stOpenWrite;
  end;

  AR := New(PArchive, Init(DestDir + ArchiveBase, Mode, 1024));
  if AR = nil then
    exit;
  AR^.SetSourceDir(SourceDir);
  ProgressBox(DefProgBox, pbShow, gettxt(txArchivingFiles), 0, 0);

  runCount := 0;
  DoneBytes := 0;
  AllBytes := 0;

  repeat {First Run sums file sizes, second run makes the archiving}

    SourceMasks.SetBuffer(masks);{strstrm}
    repeat {for all masks}
      if not SourceMasks.ReadString(mask) then
        break;
      ForEach .ForEachFile(SourceDir + mask,
                         { Give the mask where you want to start looking }
            0, 0,        { Specify File attributes here; you'll just get
                           normal Files With 0 }
            recursive,   { Search recursively?}
            @AddFile);   { Routine to call For each File }
    until false;

    if runCount = 0 then begin
      AllBytes := DoneBytes;
      DoneBytes := 0;
      AR^.SetSizeToDo(AllBytes);
    end;
    inc(runCount);

  until runCount = 2;

  FreeObject(@AR);

  ProgressBox(DefProgBox, pbHide, '', 0,0);{WaitBoxHide;}
  if DoneBytes = AllBytes then
    CompressFiles := 0
  else begin
    SysError('Archiver compress files failed');
    {SysErrorNo(erArchiverCompressFilesFailed,'');}
  end;
end;

function DecompressFiles(ArchiveName:string; DestDir:string):integer;
var AR:PArchive;
begin
  DecompressFiles := -1;

  AR := New(PArchive, Init(ArchiveName, stOpenRead, 1024));
  if AR = nil then
    exit;
  AR^.Seek(0);

  if not CreateDir(DestDir) then
    exit;

  ProgressBox(DefProgBox, pbShow, gettxt(txRestoringFiles), 0, AR^.GetSize);{langtype}
  while (AR^.ExtractNextFile(DestDir, true) <> '') and
    (AR^.ResultCode = 0) do;
  ProgressBox(DefProgBox, pbHide, '',0,0);

  DecompressFiles := AR^.ResultCode;
  FreeObject(@AR);
  {$IFDEF DEBOPENFILE}
  print_open_files(system.output);
  {$ENDIF}
end;

{$IFDEF TEST}
Procedure Test;
begin
{  MakeInstallFile(gdatafile);}
{  Install(gdatafile,'tmp');}
end;
{$ENDIF}

begin
  DefProgBox := DefaultProgressBox;
end.
