mirror of
https://github.com/doublecmd/doublecmd.git
synced 2026-06-28 10:02:14 +00:00
FIX: deb_wdx - crash with invalid .deb package
This commit is contained in:
Alexander Koblov
parent
2616db9959
commit
2f13be9b42
6 changed files with 102 additions and 1131 deletions
|
|
@ -1,191 +0,0 @@
|
|||
unit DbugIntf;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Dialogs; // We need "Dialogs" for TMsgDlgType
|
||||
|
||||
procedure SendBoolean(const Identifier: string; const Value: Boolean);
|
||||
procedure SendDateTime(const Identifier: string; const Value: TDateTime);
|
||||
procedure SendDebugEx(const Msg: string; MType: TMsgDlgType);
|
||||
procedure SendDebug(const Msg: string);
|
||||
procedure SendDebugClear;
|
||||
procedure SendInteger(const Identifier: string; const Value: Integer);
|
||||
procedure SendMethodEnter(const MethodName: string);
|
||||
procedure SendMethodExit(const MethodName: string);
|
||||
procedure SendSeparator;
|
||||
procedure SendDebugFmt(const Msg: string; const Args: array of const);
|
||||
procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TMsgDlgType);
|
||||
function StartDebugWin: hWnd;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Messages,
|
||||
SysUtils,
|
||||
Registry,
|
||||
Forms; // We need "Forms" for the Application object
|
||||
|
||||
threadvar
|
||||
MsgPrefix: AnsiString;
|
||||
|
||||
const
|
||||
chrClearCommand = #3;
|
||||
|
||||
var
|
||||
PastFailedAttemptToStartDebugWin: Boolean = False;
|
||||
|
||||
function StartDebugWin: hWnd;
|
||||
var
|
||||
DebugFilename: string;
|
||||
Buf: array[0..MAX_PATH + 1] of Char;
|
||||
si: TStartupInfo;
|
||||
pi: TProcessInformation;
|
||||
begin
|
||||
MsgPrefix := '';
|
||||
|
||||
Result := 0;
|
||||
if PastFailedAttemptToStartDebugWin then
|
||||
Exit;
|
||||
|
||||
with TRegIniFile.Create('\Software\GExperts') do
|
||||
try
|
||||
DebugFilename := ReadString('Debug', 'FilePath', '');
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
|
||||
if Trim(DebugFileName) = '' then
|
||||
begin
|
||||
GetModuleFileName(HINSTANCE, Buf, SizeOf(Buf)-1);
|
||||
DebugFileName := ExtractFilePath(StrPas(Buf))+'GDebug.exe';
|
||||
end;
|
||||
|
||||
if (Trim(DebugFilename) = '') or not FileExists(DebugFilename) then
|
||||
begin
|
||||
PastFailedAttemptToStartDebugWin := True;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
FillChar(si, SizeOf(si), #0);
|
||||
si.cb := SizeOf(si);
|
||||
si.dwFlags := STARTF_USESHOWWINDOW;
|
||||
si.wShowWindow := SW_SHOW;
|
||||
if not CreateProcess(PChar(DebugFilename), nil,
|
||||
nil, nil,
|
||||
False, 0, nil, nil,
|
||||
si, pi) then
|
||||
begin
|
||||
PastFailedAttemptToStartDebugWin := True;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
try
|
||||
WaitForInputIdle(pi.hProcess, 3 * 1000); // wait for 3 seconds to get idle
|
||||
finally
|
||||
CloseHandle(pi.hThread);
|
||||
CloseHandle(pi.hProcess);
|
||||
end;
|
||||
|
||||
Result := FindWindow('TfmDebug', nil);
|
||||
end;
|
||||
|
||||
procedure SendDebugEx(const Msg: string; MType: TMsgDlgType);
|
||||
var
|
||||
CDS: TCopyDataStruct;
|
||||
DebugWin: hWnd;
|
||||
MessageString: string;
|
||||
{$IFDEF LINUX}
|
||||
const
|
||||
MTypeStr: array[TMsgDlgType] of string =
|
||||
('Waring: ', 'Error: ', 'Information: ', 'Confirmation: ', 'Custom: ');
|
||||
{$ENDIF LINUX}
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Writeln('GX: ' + MTypeStr[MType] + Msg);
|
||||
{$ENDIF LINUX}
|
||||
{$IFNDEF LINUX}
|
||||
DebugWin := FindWindow('TfmDebug', nil);
|
||||
|
||||
if DebugWin = 0 then
|
||||
DebugWin := StartDebugWin;
|
||||
|
||||
if DebugWin <> 0 then
|
||||
begin
|
||||
MessageString := MsgPrefix + Msg;
|
||||
CDS.cbData := Length(MessageString) + 4;
|
||||
CDS.dwData := 0;
|
||||
if Msg = chrClearCommand then
|
||||
CDS.lpData := PChar(chrClearCommand+Char(Ord(MType) + 1)+ MessageString +#0)
|
||||
else
|
||||
CDS.lpData := PChar(#1+Char(Ord(MType) + 1)+ MessageString +#0);
|
||||
SendMessage(DebugWin, WM_COPYDATA, WParam(Application.Handle), LParam(@CDS));
|
||||
end;
|
||||
{$ENDIF not LINUX}
|
||||
end;
|
||||
|
||||
procedure SendDebug(const Msg: string);
|
||||
begin
|
||||
SendDebugEx(Msg, mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendDebugFmt(const Msg: string; const Args: array of const);
|
||||
begin
|
||||
SendDebugEx(Format(Msg, Args), mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TMsgDlgType);
|
||||
begin
|
||||
SendDebugEx(Format(Msg, Args), MType);
|
||||
end;
|
||||
|
||||
procedure SendDebugClear;
|
||||
begin
|
||||
SendDebug(chrClearCommand);
|
||||
end;
|
||||
|
||||
const
|
||||
Indentation = ' ';
|
||||
|
||||
procedure SendMethodEnter(const MethodName: string);
|
||||
begin
|
||||
MsgPrefix := MsgPrefix + Indentation;
|
||||
SendDebugEx('Entering ' + MethodName, mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendMethodExit(const MethodName: string);
|
||||
begin
|
||||
SendDebugEx('Exiting ' + MethodName, mtInformation);
|
||||
Delete(MsgPrefix, 1, Length(Indentation));
|
||||
end;
|
||||
|
||||
procedure SendSeparator;
|
||||
const
|
||||
SeparatorString = '------------------------------';
|
||||
begin
|
||||
SendDebugEx(SeparatorString, mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendBoolean(const Identifier: string; const Value: Boolean);
|
||||
begin
|
||||
// Note: We deliberately leave "True" and "False" as
|
||||
// hard-coded string constants, since these are
|
||||
// technical terminology which should not be localised.
|
||||
if Value then
|
||||
SendDebugEx(Identifier + '= True', mtInformation)
|
||||
else
|
||||
SendDebugEx(Identifier + '= False', mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendInteger(const Identifier: string; const Value: Integer);
|
||||
begin
|
||||
SendDebugEx(Format('%s = %d', [Identifier, Value]), mtInformation);
|
||||
end;
|
||||
|
||||
procedure SendDateTime(const Identifier: string; const Value: TDateTime);
|
||||
begin
|
||||
SendDebugEx(Identifier + '=' + DateTimeToStr(Value), mtInformation);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
|
@ -34,7 +34,7 @@ function ContentGetValue(FileName:pchar;FieldIndex,UnitIndex:integer;FieldValue:
|
|||
implementation
|
||||
|
||||
uses
|
||||
SysUtils{$IFDEF GDEBUG}, DbugIntf{$ENDIF}, debunpak;
|
||||
SysUtils, debunpak;
|
||||
|
||||
var
|
||||
IDX_PACKAGE,
|
||||
|
|
@ -121,7 +121,7 @@ begin
|
|||
end
|
||||
{$IFDEF GDEBUG}
|
||||
else
|
||||
SendDebug('Cached info reused for '+FileName);
|
||||
WriteLn('Cached info reused for '+FileName);
|
||||
{$ENDIF};
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,186 +3,154 @@ unit debunpak;
|
|||
{$mode delphi}{$H+}
|
||||
|
||||
interface
|
||||
uses
|
||||
SysUtils
|
||||
{$IFDEF GDEBUG}
|
||||
, dbugintf
|
||||
{$ENDIF};
|
||||
|
||||
//extract `control' in control.tar.gz
|
||||
function Deb_ExtractCtrlInfoFile(debfile: string; var descfile: string): boolean;
|
||||
//list out files int data.tar.gz
|
||||
function Deb_ListFileInDataMember(debfile: string; var FileList: string): integer;
|
||||
uses
|
||||
SysUtils;
|
||||
|
||||
// Extract 'control' from control.tar.gz
|
||||
function Deb_ExtractCtrlInfoFile(const DebFile: String; var DescFile: String): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
dpkg_deb, minigzip, tarfile, {$IFDEF USE_LIBTAR}libtar{$ELSE}untar, classes{$ENDIF};
|
||||
dpkg_deb, gzio, libtar;
|
||||
|
||||
var
|
||||
DebPkg: TDebianPackage; //dpkg_deb
|
||||
// TarArch: TTarArchive; //libtar
|
||||
TempDir: array[0..MAX_PATH] of char;
|
||||
DebPkg: TDebianPackage;
|
||||
TempDir: array[0..MAX_PATH] of AnsiChar;
|
||||
|
||||
function ExtractGzip(const FileName, OutName: String): Boolean;
|
||||
var
|
||||
AFile: gzFile;
|
||||
Handle: THandle;
|
||||
ALength: Integer;
|
||||
Buffer: array[Word] of Byte;
|
||||
begin
|
||||
AFile:= gzopen(FileName, 'r');
|
||||
Result:= Assigned(AFile);
|
||||
if Result then
|
||||
begin
|
||||
Handle:= FileCreate(OutName);
|
||||
Result:= (Handle <> feInvalidHandle);
|
||||
if Result then
|
||||
begin
|
||||
while True do
|
||||
begin
|
||||
ALength:= gzread(AFile, @Buffer[0], SizeOf(Buffer));
|
||||
if ALength < 0 then
|
||||
begin
|
||||
Result:= False;
|
||||
Break;
|
||||
end;
|
||||
if ALength = 0 then Break;
|
||||
if (FileWrite(Handle, Buffer[0], ALength) <> ALength) then
|
||||
begin
|
||||
Result:= False;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
FileClose(Handle);
|
||||
if not Result then DeleteFile(OutName);
|
||||
end;
|
||||
gzclose(AFile);
|
||||
end;
|
||||
end;
|
||||
|
||||
//member: 1: control.tar.gz, 2: data.tar.gz
|
||||
//return: full path of extracted file (${TEMP}\debXXXX\foo.tar.gz,
|
||||
function UnpackDebFile(DebFile: string; memberidx: integer): string;
|
||||
var
|
||||
TempFile: array[0..MAX_PATH] of char;
|
||||
FileSource,
|
||||
Index: Integer;
|
||||
FileDestination: String;
|
||||
TempFile, FileExt: String;
|
||||
begin
|
||||
{$IFDEF GDEBUG}
|
||||
SendMethodEnter('UnpackDebFile: memberidx='+IntToStr(memberidx));
|
||||
{$ENDIF}
|
||||
Result := '';
|
||||
if (memberidx<>MEMBER_CONTROL) and (memberidx<>MEMBER_DATA) then exit; //error
|
||||
|
||||
repeat
|
||||
GetTempFileName(TempDir, 'deb', random(1000), TempFile);
|
||||
StrLCopy(TempFile, PChar(ChangeFileExt(StrPas(TempFile), '.tar.gz')), MAX_PATH);
|
||||
until not FileExists(StrPas(TempFile));
|
||||
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('TempFile=' + TempFile);
|
||||
WriteLn('UnpackDebFile: memberidx='+IntToStr(memberidx));
|
||||
{$ENDIF}
|
||||
if (memberidx <> MEMBER_CONTROL) and (memberidx <> MEMBER_DATA) then Exit; //error
|
||||
|
||||
DebPkg := TDebianPackage.Create;
|
||||
if DebPkg.ReadFromFile(DebFile) < 2 then exit;
|
||||
//a debian package must have control.tar.gz and data.tar.gz
|
||||
try
|
||||
// a debian package must have control.tar.* and data.tar.*
|
||||
if DebPkg.ReadFromFile(DebFile) < 2 then Exit;
|
||||
|
||||
//extract 'control.tar.gz'
|
||||
if not DebPkg.ExtractMemberToFile(memberidx, StrPas(TempFile)) then exit;
|
||||
// Check file type
|
||||
FileExt:= TrimRight(DebPkg.FMemberList[memberidx].ar_name);
|
||||
Index:= Pos(ExtensionSeparator, FileExt);
|
||||
if Index = 0 then Exit;
|
||||
FileExt:= Copy(FileExt, Index, MaxInt);
|
||||
if (FileExt <> '.tar.gz') then Exit;
|
||||
|
||||
FileSource := StrPas(TempFile); // X:\some\where\foo.tar.gz
|
||||
FileDestination := StrPas(TempDir) +
|
||||
ChangeFileExt(ExtractFileName(FileSource), ''); // ${TempDir}\foo.tar
|
||||
TempFile:= GetTempFileName(TempDir, 'deb') + FileExt;
|
||||
|
||||
file_uncompress(FileSource);
|
||||
{$IFDEF GDEBUG}
|
||||
WriteLn('TempFile=' + TempFile);
|
||||
{$ENDIF}
|
||||
|
||||
if not FileExists(FileDestination) then
|
||||
begin
|
||||
DeleteFile(TempFile); //foo.tar.gz
|
||||
Exit;
|
||||
//extract 'control.tar.gz'
|
||||
if not DebPkg.ExtractMemberToFile(memberidx, TempFile) then Exit;
|
||||
FileDestination := StrPas(TempDir) + ChangeFileExt(ExtractFileName(TempFile), ''); // ${TEMP}\foo.tar
|
||||
ExtractGzip(TempFile, FileDestination);
|
||||
except
|
||||
// Skip
|
||||
end;
|
||||
|
||||
DeleteFile(TempFile);
|
||||
|
||||
if not FileExists(FileDestination) then Exit;
|
||||
|
||||
Result := FileDestination;
|
||||
|
||||
DeleteFile(PChar(FileSource));
|
||||
{$IFDEF GDEBUG}
|
||||
SendMethodExit('UnpackDebFile');
|
||||
WriteLn('UnpackDebFile');
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
//function Deb_ExtractDataFileList(debfile: string; var FileList: string): integer;
|
||||
function Deb_ListFileInDataMember;
|
||||
var
|
||||
tarfilename: string;
|
||||
fname : string;
|
||||
fsize : integer;
|
||||
TarFile: TTarFile;
|
||||
begin
|
||||
tarfilename := UnpackDebFile(debfile, MEMBER_DATA);
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('tarfilename=' + tarfilename);
|
||||
{$ENDIF}
|
||||
FileList:='';
|
||||
Result := 0;
|
||||
if not FileExists(tarfilename) then exit;
|
||||
|
||||
TarFile := TTarFile.Create(tarfilename);
|
||||
try
|
||||
while not TarFile.Eof do
|
||||
begin
|
||||
fname := TarFile.GetNextFilename;
|
||||
fsize := TarFile.GetNextSize;
|
||||
if fsize>0 then
|
||||
begin
|
||||
TarFile.GetNextDate;
|
||||
TarFile.SkipFile;
|
||||
end;
|
||||
if FileList='' then
|
||||
FileList := fname
|
||||
else
|
||||
FileList := FileList + #13#10 + fname;
|
||||
Inc(Result);
|
||||
end;
|
||||
finally
|
||||
TarFile.Free;
|
||||
DeleteFile(PChar(tarfilename));
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
//function ExtractDebInfoFile(debfile: string; var descfile: string): boolean;
|
||||
//debfile: full path of .deb file to extract member from
|
||||
//descfile: [out] full path of extracted control file (${TEMP}\debXXXX\control)
|
||||
// you should remove this file (and the temp folder ${TEMP}\debXXXX after use.
|
||||
//return: succeed or not
|
||||
function Deb_ExtractCtrlInfoFile;
|
||||
function Deb_ExtractCtrlInfoFile(const DebFile: string; var DescFile: string): boolean;
|
||||
var
|
||||
tarfilename: string;
|
||||
{$IFDEF USE_LIBTAR}
|
||||
TA: TTarArchive;
|
||||
DirRec: TTarDirRec;
|
||||
{$ELSE USE_TARFILE}
|
||||
Untar1: TUntar;
|
||||
strlst: TStringList;
|
||||
{$ENDIF}
|
||||
TarFileName: String;
|
||||
begin
|
||||
Result := false;
|
||||
Result := False;
|
||||
{$IFDEF GDEBUG}
|
||||
SendMethodEnter('ExtractDebInfoFile');
|
||||
WriteLn('ExtractDebInfoFile');
|
||||
{$ENDIF}
|
||||
tarfilename := UnpackDebFile(debfile, MEMBER_CONTROL);
|
||||
TarFileName := UnpackDebFile(DebFile, MEMBER_CONTROL);
|
||||
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('tarfilename=' + tarfilename);
|
||||
WriteLn('tarfilename=' + tarfilename);
|
||||
{$ENDIF}
|
||||
if not FileExists(tarfilename) then exit;
|
||||
if not FileExists(TarFileName) then Exit;
|
||||
|
||||
{$IFDEF USE_LIBTAR} //libtar seems to be bad
|
||||
descfile := StrPas(TempDir) + 'control.txt';
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('descfile=' + descfile);
|
||||
{$ENDIF}
|
||||
TA := TTarArchive.Create(tarfilename);
|
||||
TA.Reset;
|
||||
while TA.FindNext(DirRec) do
|
||||
DescFile := StrPas(TempDir) + 'control.txt';
|
||||
{$IFDEF GDEBUG}
|
||||
WriteLn('descfile=' + descfile);
|
||||
{$ENDIF}
|
||||
TA := TTarArchive.Create(TarFileName);
|
||||
|
||||
while TA.FindNext(DirRec) do
|
||||
begin
|
||||
{$IFDEF GDEBUG}
|
||||
WriteLn('DirRec.Name=' + DirRec.Name);
|
||||
{$ENDIF}
|
||||
if (DirRec.Name = './control') or (DirRec.Name = '.\control') or (DirRec.Name = 'control') then
|
||||
begin
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('DirRec.Name=' + DirRec.Name);
|
||||
{$ENDIF}
|
||||
if (DirRec.Name = './control') or (DirRec.Name = '.\control') or (DirRec.Name = 'control') then
|
||||
begin
|
||||
TA.ReadFile(descfile);
|
||||
break;
|
||||
end;
|
||||
TA.ReadFile(DescFile);
|
||||
Break;
|
||||
end;
|
||||
TA.Free;
|
||||
{$ELSE}
|
||||
Untar1 := TUntar.Create(nil);
|
||||
Untar1.FileSource := tarfilename;
|
||||
//Untar1.UnpackPath := TempDir + 'deb4wii';
|
||||
Untar1.UnpackPath := TempDir + ChangeFileExt(ExtractFileName(Untar1.FileSource), ''); // ${TempDir}\foo
|
||||
{$IFDEF GDEBUG}
|
||||
SendDebug('UnpackPath=' + Untar1.UnpackPath);
|
||||
{$ENDIF}
|
||||
strlst := TStringList.Create;
|
||||
strlst.Add('control');
|
||||
strlst.Add('./control');
|
||||
strlst.Add('.\control');
|
||||
Untar1.OverwriteMode := omReplace; //shit!
|
||||
Untar1.UntarSelected(strlst);
|
||||
//Untar1.Untar; //untar all
|
||||
descfile := IncludeTrailingBackSlash(Untar1.UnpackPath) + 'control';
|
||||
strlst.Free;
|
||||
Untar1.Free;
|
||||
{$ENDIF}
|
||||
end;
|
||||
TA.Free;
|
||||
|
||||
DeleteFile(PChar(tarfilename)); //foo.tar
|
||||
DeleteFile(TarFileName); //foo.tar
|
||||
Result := true;
|
||||
{$IFDEF GDEBUG}
|
||||
SendMethodExit('ExtractDebInfoFile');
|
||||
WriteLn('ExtractDebInfoFile');
|
||||
{$ENDIF}
|
||||
(*
|
||||
filelist := '';
|
||||
|
|
@ -196,13 +164,12 @@ begin
|
|||
end;
|
||||
|
||||
initialization
|
||||
DebPkg := TDebianPackage.Create;
|
||||
TempDir:= GetTempDir;
|
||||
Randomize;
|
||||
TempDir:= GetTempDir;
|
||||
DebPkg := TDebianPackage.Create;
|
||||
|
||||
finalization
|
||||
DebPkg.Free;
|
||||
// TarArc.Free;
|
||||
|
||||
end.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,221 +0,0 @@
|
|||
{
|
||||
minigzip.c -- simulate gzip using the zlib compression library
|
||||
Copyright (C) 1995-1998 Jean-loup Gailly.
|
||||
|
||||
minigzip is a minimal implementation of the gzip utility. This is
|
||||
only an example of using zlib and isn't meant to replace the
|
||||
full-featured gzip. No attempt is made to deal with file systems
|
||||
limiting names to 14 or 8+3 characters, etc... Error checking is
|
||||
very limited. So use minigzip only for testing; use gzip for the
|
||||
real thing. On MSDOS, use only on file names without extension
|
||||
or in pipe mode.
|
||||
|
||||
Pascal tranlastion based on code contributed by Francisco Javier Crespo
|
||||
Copyright (C) 1998 by Jacques Nomssi Nzali
|
||||
For conditions of distribution and use, see copyright notice in readme.txt
|
||||
}
|
||||
|
||||
unit minigzip;
|
||||
|
||||
{$mode fpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
gzio;
|
||||
|
||||
procedure gz_compress (var infile:file; outfile:gzFile);
|
||||
procedure gz_uncompress (infile:gzFile; var outfile:file);
|
||||
procedure file_compress (filename:string; mode:string);
|
||||
procedure file_uncompress (filename:string);
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
BUFLEN = 16384 ;
|
||||
GZ_SUFFIX = '.gz' ;
|
||||
|
||||
{$DEFINE MAXSEF_64K}
|
||||
|
||||
var
|
||||
buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
|
||||
prog : string;
|
||||
|
||||
{ ERROR =====================================================================
|
||||
|
||||
Display error message and exit
|
||||
|
||||
============================================================================}
|
||||
|
||||
procedure error (msg:string);
|
||||
begin
|
||||
writeln (prog,': ',msg);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
{ GZ_COMPRESS ===============================================================
|
||||
|
||||
Compress input to output then close both files
|
||||
|
||||
============================================================================}
|
||||
|
||||
procedure gz_compress (var infile:file; outfile:gzFile);
|
||||
var
|
||||
len : cardinal;
|
||||
ioerr : integer;
|
||||
err : integer;
|
||||
begin
|
||||
|
||||
while true do begin
|
||||
|
||||
{$I-}
|
||||
blockread (infile, buf, BUFLEN, len);
|
||||
{$I+}
|
||||
ioerr := IOResult;
|
||||
if (ioerr <> 0) then begin
|
||||
writeln ('read error: ',ioerr);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
if (len = 0) then break;
|
||||
|
||||
if (gzwrite (outfile, @buf, len) <> len)
|
||||
then error (gzerror (outfile, err));
|
||||
|
||||
end; {WHILE}
|
||||
|
||||
close (infile);
|
||||
if (gzclose (outfile) <> 0{Z_OK})
|
||||
then error ('gzclose error');
|
||||
end;
|
||||
|
||||
|
||||
{ GZ_UNCOMPRESS =============================================================
|
||||
|
||||
Uncompress input to output then close both files
|
||||
|
||||
============================================================================}
|
||||
|
||||
procedure gz_uncompress (infile:gzFile; var outfile:file);
|
||||
var
|
||||
len : integer;
|
||||
written : cardinal;
|
||||
ioerr : integer;
|
||||
err : integer;
|
||||
begin
|
||||
while true do begin
|
||||
|
||||
len := gzread (infile, @buf, BUFLEN);
|
||||
if (len < 0)
|
||||
then error (gzerror (infile, err));
|
||||
if (len = 0)
|
||||
then break;
|
||||
|
||||
{$I-}
|
||||
blockwrite (outfile, buf, len, written);
|
||||
{$I+}
|
||||
if (written <> len)
|
||||
then error ('write error');
|
||||
|
||||
end; {WHILE}
|
||||
|
||||
{$I-}
|
||||
close (outfile);
|
||||
{$I+}
|
||||
ioerr := IOResult;
|
||||
if (ioerr <> 0) then begin
|
||||
writeln ('close error: ',ioerr);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
if (gzclose (infile) <> 0{Z_OK})
|
||||
then error ('gzclose error');
|
||||
end;
|
||||
|
||||
|
||||
{ FILE_COMPRESS =============================================================
|
||||
|
||||
Compress the given file:
|
||||
create a corresponding .gz file and remove the original
|
||||
|
||||
============================================================================}
|
||||
|
||||
procedure file_compress (filename:string; mode:string);
|
||||
var
|
||||
infile : file;
|
||||
outfile : gzFile;
|
||||
ioerr : integer;
|
||||
outname : string;
|
||||
begin
|
||||
Assign (infile, filename);
|
||||
{$I-}
|
||||
Reset (infile,1);
|
||||
{$I+}
|
||||
ioerr := IOResult;
|
||||
if (ioerr <> 0) then begin
|
||||
writeln ('open error: ',ioerr);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
outname := filename + GZ_SUFFIX;
|
||||
outfile := gzopen (outname, mode);
|
||||
|
||||
if (outfile = NIL) then begin
|
||||
writeln (prog,': can''t gzopen ',outname);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
gz_compress(infile, outfile);
|
||||
erase (infile);
|
||||
end;
|
||||
|
||||
|
||||
{ FILE_UNCOMPRESS ===========================================================
|
||||
|
||||
Uncompress the given file and remove the original
|
||||
|
||||
============================================================================}
|
||||
|
||||
procedure file_uncompress (filename:string);
|
||||
var
|
||||
inname : string;
|
||||
outname : string;
|
||||
infile : gzFile;
|
||||
outfile : file;
|
||||
ioerr : integer;
|
||||
len : integer;
|
||||
begin
|
||||
len := Length(filename);
|
||||
|
||||
if (copy(filename,len-2,3) = GZ_SUFFIX) then begin
|
||||
inname := filename;
|
||||
outname := copy(filename,0,len-3);
|
||||
end
|
||||
else begin
|
||||
inname := filename + GZ_SUFFIX;
|
||||
outname := filename;
|
||||
end;
|
||||
|
||||
infile := gzopen (inname, 'r');
|
||||
if (infile = NIL) then begin
|
||||
writeln (prog,': can''t gzopen ',inname);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
Assign (outfile, outname);
|
||||
{$I-}
|
||||
Rewrite (outfile,1);
|
||||
{$I+}
|
||||
ioerr := IOResult;
|
||||
if (ioerr <> 0) then begin
|
||||
writeln ('open error: ',ioerr);
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
gz_uncompress (infile, outfile);
|
||||
|
||||
{ erase (infile); }
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -1,234 +0,0 @@
|
|||
unit tarfile;
|
||||
|
||||
interface
|
||||
|
||||
uses classes, sysutils, math;
|
||||
|
||||
const EXP_FILENAME = 0;
|
||||
EXP_SIZE = 1;
|
||||
EXP_DATE = 2;
|
||||
EXP_BODY = 3;
|
||||
EXP_ERROR = 4;
|
||||
EXP_EOF = 5;
|
||||
|
||||
SECSIZE = 512;
|
||||
// SECSPERBLOCK = 120;
|
||||
BUFSIZE = SECSIZE; // * SECSPERBLOCK;
|
||||
|
||||
type
|
||||
TBuffer = Array [0..Pred(BUFSIZE)] Of byte;
|
||||
TDateTimeRec = record
|
||||
sec : integer;
|
||||
min : integer;
|
||||
hour : integer;
|
||||
day : integer;
|
||||
month : integer;
|
||||
year : integer;
|
||||
end;
|
||||
|
||||
TTarFile = class
|
||||
private
|
||||
FTarF : TFileStream;
|
||||
FExpecting : byte;
|
||||
FName : string;
|
||||
FBuffer : TBuffer;
|
||||
FLen : longint;
|
||||
FUnreadSec : integer;
|
||||
function CrackUnixDateTime( UnixDate : longint) : TDateTimeRec;
|
||||
procedure AdjustFilename( var filename : string);
|
||||
public
|
||||
constructor Create( filename : string);
|
||||
destructor Free;
|
||||
function EOF : boolean;
|
||||
function Progress : integer;
|
||||
function GetNextFilename : string;
|
||||
function GetNextSize : longint;
|
||||
function GetNextDate : TDateTimeRec;
|
||||
function ReadFile( var buffer; maximum : longint) : longint;
|
||||
Procedure SkipFile;
|
||||
protected
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
// **************************************************
|
||||
// Private part
|
||||
// **************************************************
|
||||
{$WRITEABLECONST ON}
|
||||
|
||||
function TTarFile.CrackUnixDateTime( UnixDate : longint) : TDateTimeRec;
|
||||
Const monlen : Array [1..12] Of byte
|
||||
= (31,28,31,30,31,30,31,31,30,31,30,31);
|
||||
var dt : TDateTimeRec;
|
||||
begin
|
||||
dt.sec := UnixDate mod 60;
|
||||
UnixDate := UnixDate div 60;
|
||||
dt.min := UnixDate mod 60;
|
||||
UnixDate := UnixDate div 60;
|
||||
dt.hour := UnixDate mod 24;
|
||||
UnixDate := UnixDate div 24;
|
||||
|
||||
dt.year := 1970;
|
||||
while ((UnixDate>=365) and (dt.year mod 4 <> 0)) or
|
||||
((UnixDate>=366) and (dt.year mod 4 = 0 )) do
|
||||
begin
|
||||
if dt.year mod 4 = 0 then UnixDate := UnixDate - 1;
|
||||
UnixDate := UnixDate - 365;
|
||||
Inc(dt.year)
|
||||
end;
|
||||
|
||||
dt.month := 1;
|
||||
if dt.year mod 4 = 0 then Inc(monlen[2]);
|
||||
while UnixDate>=monlen[dt.month] do
|
||||
begin
|
||||
UnixDate := UnixDate - monlen[dt.month];
|
||||
Inc(dt.month)
|
||||
end;
|
||||
if dt.year mod 4 = 0 then Dec(monlen[2]);
|
||||
|
||||
dt.day := UnixDate + 1;
|
||||
|
||||
Result := dt
|
||||
end;
|
||||
|
||||
Procedure TTarFile.AdjustFilename(Var filename : string);
|
||||
|
||||
Const badletter : Set Of char = ['+',' ',':','<','>','|'];
|
||||
Var i : byte;
|
||||
Begin { openfile }
|
||||
For i := Length(filename) DownTo 1 Do
|
||||
Begin
|
||||
If filename[i] = '/' Then filename[i] := '\';
|
||||
If filename[i] In badletter Then filename[i] := '_';
|
||||
End
|
||||
end;
|
||||
|
||||
// **************************************************
|
||||
// Public part
|
||||
// **************************************************
|
||||
|
||||
constructor TTarFile.Create( filename : string);
|
||||
begin
|
||||
FTarF := TFileStream.Create( filename, fmOpenRead or fmShareDenyWrite);
|
||||
end;
|
||||
|
||||
destructor TTarFile.Free;
|
||||
begin
|
||||
FTarF.Free;
|
||||
end;
|
||||
|
||||
function TTarFile.EOF : boolean;
|
||||
begin
|
||||
EOF := FTarF.Size = FTarF.Position;
|
||||
end;
|
||||
|
||||
function TTarFile.Progress : integer;
|
||||
begin
|
||||
Progress := Floor((FTarF.Position / FTarF.Size) * 100)
|
||||
end;
|
||||
|
||||
function TTarFile.GetNextFilename : string;
|
||||
var iread : integer;
|
||||
i : integer;
|
||||
begin
|
||||
FName := '';
|
||||
if (not(EOF) and (FExpecting = EXP_FILENAME)) then
|
||||
begin
|
||||
iread := FTarF.Read( FBuffer, SECSIZE);
|
||||
If iread <> SECSIZE Then FExpecting := EXP_ERROR
|
||||
else begin
|
||||
i := 0;
|
||||
While (FBuffer[i] <> 0) And (i < 254) Do
|
||||
begin
|
||||
FName := FName + char(FBuffer[i]);
|
||||
Inc(i);
|
||||
end;
|
||||
if i > 0 then
|
||||
begin
|
||||
FExpecting := EXP_SIZE;
|
||||
AdjustFilename( FName)
|
||||
end
|
||||
else begin
|
||||
i := 0;
|
||||
// Lazy evaluation needed to prvent reading from FBuffer[SECSIZE]
|
||||
while (i < SECSIZE) and (FBuffer[i]=0) do Inc(i);
|
||||
if i < SECSIZE then
|
||||
FExpecting := EXP_FILENAME
|
||||
else begin
|
||||
FExpecting := EXP_EOF;
|
||||
FTarF.Position := FTarF.Size
|
||||
end
|
||||
end
|
||||
end
|
||||
end;
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
function TTarFile.GetNextSize : longint;
|
||||
var i : byte;
|
||||
begin
|
||||
FLen := 0;
|
||||
GetNextSize := 0;
|
||||
if (not(EOF) and (FExpecting = EXP_SIZE)) then
|
||||
begin
|
||||
For i := $7C To $86 Do
|
||||
If (FBuffer[i] >= 48) And (FBuffer[i] <= 55) Then
|
||||
FLen := 8*FLen + FBuffer[i] - 48;
|
||||
if FLen > 0 then
|
||||
FExpecting := EXP_DATE
|
||||
else
|
||||
FExpecting := EXP_FILENAME;
|
||||
|
||||
GetNextSize := FLen
|
||||
end;
|
||||
FUnreadSec := (SECSIZE - (FLen mod SECSIZE)) mod SECSIZE
|
||||
end;
|
||||
|
||||
function TTarFile.GetNextDate : TDateTimeRec;
|
||||
var UnixDate : longint;
|
||||
i : byte;
|
||||
begin
|
||||
UnixDate := 0;
|
||||
if FExpecting = EXP_DATE then
|
||||
begin
|
||||
For i := $88 To $92 Do
|
||||
If (FBuffer[i] >= 48) And (FBuffer[i] <= 55) Then
|
||||
UnixDate := 8*UnixDate + FBuffer[i] - 48;
|
||||
|
||||
FExpecting := EXP_BODY
|
||||
end;
|
||||
Result := CrackUnixDateTime( UnixDate)
|
||||
end;
|
||||
|
||||
function TTarFile.ReadFile( var buffer; maximum : longint) : longint;
|
||||
var iread : longint;
|
||||
buff : TBuffer;
|
||||
begin
|
||||
iread := 0;
|
||||
if (FLen > FTarF.Size - FTarF.Position) or
|
||||
(FExpecting <> EXP_BODY)
|
||||
then FExpecting := EXP_ERROR
|
||||
else begin
|
||||
iread := FTarF.Read( buffer, min(maximum,FLen));
|
||||
FLen := FLen - iread;
|
||||
if FLen = 0 then
|
||||
begin
|
||||
FExpecting := EXP_FILENAME;
|
||||
if FUnreadSec > 0 then FTarF.Read( buff, FUnreadSec)
|
||||
end
|
||||
end;
|
||||
ReadFile := iread
|
||||
end;
|
||||
|
||||
procedure TTarFile.SkipFile;
|
||||
begin
|
||||
if (FLen > FTarF.Size - FTarF.Position) or
|
||||
(FExpecting <> EXP_BODY)
|
||||
then FExpecting := EXP_ERROR
|
||||
else begin
|
||||
FTarF.Position := FTarF.Position + FLen + FUnreadSec;
|
||||
FExpecting := EXP_FILENAME
|
||||
end
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -1,350 +0,0 @@
|
|||
unit UnTar;
|
||||
|
||||
{$mode delphi}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
{$IFDEF ABOUTDLG}DsgnIntf, {$ENDIF}tarfile;
|
||||
|
||||
CONST BUFSIZE = 512 * 128; // 512 = SECSIZE in unit tarfile
|
||||
|
||||
type
|
||||
TZeroHundred = 0..100;
|
||||
TOverwriteMode = ( omSkip, omRename, omReplace );
|
||||
TNextFile = record
|
||||
name : string;
|
||||
size : longint;
|
||||
timestamp : TDateTime
|
||||
end;
|
||||
|
||||
{$IFDEF ABOUTDLG}
|
||||
TAboutProperty = class(TPropertyEditor)
|
||||
public
|
||||
procedure Edit; override;
|
||||
function GetAttributes: TPropertyAttributes; override;
|
||||
function GetValue: string; override;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
TUnTar = class(TComponent)
|
||||
private
|
||||
{ Private declarations }
|
||||
{$IFDEF ABOUTDLG}
|
||||
FAbout : TAboutProperty;
|
||||
{$ENDIF}
|
||||
FOnNextFile : TNotifyEvent;
|
||||
FNextFile : TNextFile;
|
||||
FCreateEmptyDir: boolean;
|
||||
FOnExtractOverwrite : TNotifyEvent;
|
||||
FOnProgress : TNotifyEvent;
|
||||
FProgress : integer;
|
||||
FProgressStep : TZeroHundred;
|
||||
FOverwriteMode : TOverwriteMode;
|
||||
FOverwriteThisTime : TOverwriteMode;
|
||||
FOverwriteFilename : String;
|
||||
FFileSource : string;
|
||||
FUnpackPath : string;
|
||||
FNewFileName : string;
|
||||
procedure DoProgress( tarfile : TTarFile);
|
||||
procedure CreateNextFile( tarfile: TTarfile);
|
||||
function TranslateDate(dt: TDateTimeRec): longint;
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure DoOnNextFile; virtual;
|
||||
procedure DoOnExtractOverwrite; virtual;
|
||||
procedure DoOnProgress; virtual;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create( AOwner: TComponent); override;
|
||||
// destructor Free;
|
||||
procedure UnTar;
|
||||
procedure UnTarSelected( list: TStringList);
|
||||
procedure GetInfo;
|
||||
property Progress : integer
|
||||
read FProgress;
|
||||
property NextFile : TNextfile
|
||||
read FNextFile;
|
||||
property OverwriteThisTime : TOverwriteMode
|
||||
read FOverwriteThisTime write FOverwriteThisTime;
|
||||
property OverwriteFilename : String
|
||||
read FOverwriteFilename write FOverwriteFilename;
|
||||
published
|
||||
{ Published declarations }
|
||||
{$IFDEF ABOUTDLG}
|
||||
property About: TAboutProperty read FAbout write FAbout;
|
||||
{$ENDIF}
|
||||
property FileSource : String
|
||||
read FFileSource write FFileSource;
|
||||
property UnpackPath : String
|
||||
read FUnpackPath write FUnpackPath;
|
||||
property ProgressStep : TZeroHundred
|
||||
read FProgressStep write FProgressStep;
|
||||
property OnProgress : TNotifyEvent
|
||||
read FOnProgress write FOnProgress;
|
||||
Property OverwriteMode : TOverwriteMode
|
||||
read FOverwriteMode write FOverwriteMode;
|
||||
Property CreateEmptyDir: boolean
|
||||
read FCreateEmptyDir write FCreateEmptyDir;
|
||||
Property OnExtractOverwrite : TNotifyEvent
|
||||
read FOnExtractOverwrite write FOnExtractOverwrite;
|
||||
Property OnNextFile : TNotifyEvent
|
||||
read FOnNextFile write FOnNextFile;
|
||||
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF ABOUTDLG}uses utils;{$ENDIF}
|
||||
|
||||
{$IFDEF ABOUTDLG}
|
||||
procedure TAboutProperty.Edit;
|
||||
var utils : TUtils;
|
||||
begin
|
||||
ShowMessage(utils.CreateAboutMsg('DelphiUnTar'))
|
||||
end;
|
||||
|
||||
function TAboutProperty.GetAttributes: TPropertyAttributes;
|
||||
begin
|
||||
Result := [paMultiSelect, paDialog, paReadOnly];
|
||||
end;
|
||||
|
||||
function TAboutProperty.GetValue: string;
|
||||
begin
|
||||
Result := 'DelphiUnTar';
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
constructor TUnTar.Create( AOwner: TComponent);
|
||||
begin
|
||||
inherited Create( AOwner);
|
||||
FFileSource := '';
|
||||
FUnpackPath := '';
|
||||
FProgressStep := 0;
|
||||
FCreateEmptyDir := false;
|
||||
//FOverwriteMode := omRename
|
||||
FOverwriteMode := omReplace;
|
||||
end;
|
||||
|
||||
procedure TUnTar.DoOnNextFile;
|
||||
begin
|
||||
if Assigned (FOnNextFile) then
|
||||
FOnNextFile (self)
|
||||
end;
|
||||
|
||||
procedure TUnTar.DoOnExtractOverwrite;
|
||||
begin
|
||||
if Assigned (FOnExtractOverwrite) then
|
||||
FOnExtractOverwrite (self)
|
||||
end;
|
||||
|
||||
procedure TUnTar.DoOnProgress;
|
||||
begin
|
||||
if Assigned (FOnProgress) then
|
||||
FOnProgress (self)
|
||||
end;
|
||||
|
||||
procedure TUnTar.DoProgress( tarfile : TTarFile);
|
||||
var dummy : integer;
|
||||
begin
|
||||
if FProgressStep > 0 then
|
||||
begin
|
||||
dummy := tarfile.Progress;
|
||||
if (dummy >= FProgress + FProgressStep) or
|
||||
(dummy = 100) then
|
||||
begin
|
||||
FProgress := dummy - (dummy mod FProgressStep);
|
||||
if dummy = 100 then FProgress := dummy;
|
||||
DoOnProgress
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
function TUnTar.TranslateDate( dt : TDateTimeRec) : longint;
|
||||
begin
|
||||
Result := DateTimeToFileDate(
|
||||
EncodeDate( dt.year, dt.month, dt.day) +
|
||||
EncodeTime( dt.hour, dt.min, dt.sec, 0))
|
||||
end;
|
||||
|
||||
procedure TUnTar.CreateNextFile( tarfile: TTarfile);
|
||||
type TBuffer = Array [0..Pred(BUFSIZE)] Of byte;
|
||||
var outfiledir: string;
|
||||
outf: TFileStream;
|
||||
iread: longint;
|
||||
buffer: TBuffer;
|
||||
begin
|
||||
outfileDir := ExtractFileDir(FNextFile.name);
|
||||
// Check if sub-dir exists, if not create
|
||||
if not(DirectoryExists(outfileDir)) and (outfileDir<>'') then
|
||||
begin
|
||||
outfileDir := ExpandFileName(outfileDir);
|
||||
ForceDirectories(outfileDir);
|
||||
end;
|
||||
|
||||
if outfileDir <> '' then outfileDir := outfileDir + PathDelim;
|
||||
FNewFilename := outfileDir+ExtractFileName(FNextFile.name);
|
||||
|
||||
FOverwriteThisTime := omRename;
|
||||
while (FileExists( FNewFilename)) and
|
||||
(FOverwriteMode = omRename)and
|
||||
(FOverwriteThisTime = omRename) do
|
||||
begin
|
||||
FOverwriteFilename := '';
|
||||
// Raise event to ask what should be done
|
||||
DoOnExtractOverwrite;
|
||||
if (FOverwriteThisTime = omRename) and
|
||||
(FOverwriteFilename <> '') then
|
||||
FNewFilename := FOverwriteFilename
|
||||
end;
|
||||
|
||||
if (not FileExists( FNewFilename)) or
|
||||
(FOverwriteMode = omReplace) or
|
||||
(FOverwriteThisTime = omReplace) then
|
||||
begin
|
||||
outf := TFileStream.Create(FNewFilename, fmCreate or fmShareDenyWrite);
|
||||
|
||||
while FNextFile.size > 0 do
|
||||
begin
|
||||
iread := tarfile.ReadFile( buffer, BUFSIZE);
|
||||
outf.Write( buffer, iread);
|
||||
FNextFile.size := FNextFile.size - iread;
|
||||
DoProgress(tarfile)
|
||||
end;
|
||||
FileSetDate(outf.Handle, DateTimeToFileDate(FNextFile.timestamp));
|
||||
outf.Free
|
||||
end else
|
||||
begin
|
||||
tarfile.SkipFile; // We do not need the file
|
||||
DoProgress(tarfile)
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TUnTar.UnTar;
|
||||
var oldDir, outfileDir : string;
|
||||
tarfile : TTarFile;
|
||||
begin
|
||||
FProgress := 0;
|
||||
oldDir := getCurrentDir;
|
||||
// check if destination-path exists
|
||||
if FUnpackPath <> '' then
|
||||
begin
|
||||
if not(DirectoryExists(FUnpackPath)) then
|
||||
ForceDirectories(FUnpackPath);
|
||||
setCurrentDir(FUnpackPath);
|
||||
end;
|
||||
|
||||
tarfile := TTarFile.Create( FFileSource);
|
||||
DoProgress(tarfile);
|
||||
while not( tarfile.EOF) do
|
||||
begin
|
||||
FNextFile.name := tarfile.GetNextFilename;
|
||||
DoProgress( tarfile);
|
||||
outfileDir := ExtractFileDir(FNextFile.name);
|
||||
|
||||
if FCreateEmptyDir then
|
||||
// Check if sub-dir exists, if not create
|
||||
if not(DirectoryExists(outfileDir)) and (outfileDir<>'') then
|
||||
begin
|
||||
outfileDir := ExpandFileName(outfileDir);
|
||||
ForceDirectories(outfileDir);
|
||||
end;
|
||||
|
||||
FNextFile.size := tarfile.GetNextSize;
|
||||
if FNextFile.size > 0 then
|
||||
begin
|
||||
//FNextFile.timestamp := tarfile.GetNextDate;
|
||||
FNextFile.timestamp := TranslateDate(tarfile.GetNextDate);
|
||||
|
||||
DoOnNextFile; // raise event that we start with new file
|
||||
// Info is now read and in FNextFile
|
||||
// Create the file
|
||||
CreateNextFile(tarfile)
|
||||
end
|
||||
end;
|
||||
DoProgress( tarfile);
|
||||
tarfile.Free;
|
||||
|
||||
setCurrentDir(oldDir)
|
||||
end;
|
||||
|
||||
procedure TUnTar.UnTarSelected( list: TStringList);
|
||||
var oldDir, outfileDir : string;
|
||||
tarfile : TTarFile;
|
||||
begin
|
||||
FProgress := 0;
|
||||
oldDir := getCurrentDir;
|
||||
// check if destination-path exists
|
||||
if FUnpackPath <> '' then
|
||||
begin
|
||||
if not(DirectoryExists(FUnpackPath)) then
|
||||
ForceDirectories(FUnpackPath);
|
||||
setCurrentDir(FUnpackPath);
|
||||
end;
|
||||
|
||||
tarfile := TTarFile.Create( FFileSource);
|
||||
DoProgress(tarfile);
|
||||
while not( tarfile.EOF) do
|
||||
begin
|
||||
FNextFile.name := tarfile.GetNextFilename;
|
||||
DoProgress( tarfile);
|
||||
outfileDir := ExtractFileDir(FNextFile.name);
|
||||
|
||||
FNextFile.size := tarfile.GetNextSize;
|
||||
if FNextFile.size > 0 then
|
||||
begin
|
||||
//FNextFile.timestamp := tarfile.GetNextDate;
|
||||
FNextFile.timestamp := TranslateDate(tarfile.GetNextDate);
|
||||
|
||||
if list.IndexOf(FNextFile.Name) > -1 then
|
||||
begin
|
||||
DoOnNextFile; // raise event that we start with new file
|
||||
// Info is now read and in FNextFile
|
||||
// Create the file
|
||||
CreateNextFile(tarfile)
|
||||
end else
|
||||
tarFile.SkipFile
|
||||
end
|
||||
end;
|
||||
DoProgress( tarfile);
|
||||
tarfile.Free;
|
||||
|
||||
setCurrentDir(oldDir)
|
||||
end;
|
||||
|
||||
procedure TUnTar.GetInfo;
|
||||
var tarfile : TTarFile;
|
||||
begin
|
||||
FProgress := 0;
|
||||
tarfile := TTarFile.Create( FFileSource);
|
||||
DoProgress( tarfile);
|
||||
while not( tarfile.EOF) do
|
||||
begin
|
||||
FNextFile.name := tarfile.GetNextFilename;
|
||||
FNextFile.size := tarfile.GetNextSize;
|
||||
DoProgress( tarfile);
|
||||
if FNextFile.size > 0 then
|
||||
begin
|
||||
//FNextFile.timestamp := tarfile.GetNextDate;
|
||||
FNextFile.timestamp := TranslateDate(tarfile.GetNextDate);
|
||||
tarfile.SkipFile;
|
||||
DoOnNextFile;
|
||||
DoProgress( tarfile)
|
||||
end
|
||||
end;
|
||||
DoProgress( tarfile);
|
||||
tarfile.Free;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('Samples', [TUnTar]);
|
||||
{$IFDEF ABOUTDLG}
|
||||
RegisterPropertyEditor(TypeInfo(TAboutProperty), TUnTar, 'ABOUT', TAboutProperty);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
Loading…
Add table
Add a link
Reference in a new issue