mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity
doublecmd/src/platform/utarwriter.pas

809 lines
23 KiB
ObjectPascal
Raw Blame History

{
Double Commander
-------------------------------------------------------------------------
Simple TAR archive writer
Copyright (C) 2011-2019 Alexander Koblov (alexx2000@mail.ru)
This unit is based on libtar.pp from the Free Component Library (FCL)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
}
unit uTarWriter;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,LazUtf8,
uGlobs, uWcxModule, WcxPlugin, DCClassesUtf8,
uFile,
uFileSource,
uFileSourceOperationUI,
uFileSourceOperation,
uFileSourceCopyOperation;
const
RECORDSIZE = 512;
NAMSIZ = 100;
TUNMLEN = 32;
TGNMLEN = 32;
CHKBLANKS = #32#32#32#32#32#32#32#32;
USTAR = 'ustar'#32#32;
LONGLINK = '././@LongLink';
LONGLEN = RECORDSIZE * 64;
LONGMAX = RECORDSIZE * 128;
type
TDataWriteProcedure = procedure(Buffer: Pointer; BytesToWrite: Int64) of object;
TUpdateStatisticsFunction = procedure(var NewStatistics: TFileSourceCopyOperationStatistics) of object;
{ TTarHeader }
TTarHeader = packed record
Name: array [0..NAMSIZ - 1] of AnsiChar;
Mode: array [0..7] of AnsiChar;
UID: array [0..7] of AnsiChar;
GID: array [0..7] of AnsiChar;
Size: array [0..11] of AnsiChar;
MTime: array [0..11] of AnsiChar;
ChkSum: array [0..7] of AnsiChar;
TypeFlag: AnsiChar;
LinkName: array [0..NAMSIZ - 1] of AnsiChar;
Magic: array [0..7] of AnsiChar;
UName: array [0..TUNMLEN - 1] of AnsiChar;
GName: array [0..TGNMLEN - 1] of AnsiChar;
DevMajor: array [0..7] of AnsiChar;
DevMinor: array [0..7] of AnsiChar;
Prefix: array [0..154] of AnsiChar;
end;
{ TTarHeaderEx }
TTarHeaderEx = packed record
case Boolean of
True: (HR: TTarHeader);
False: (HA: array [0..RECORDSIZE - 1] of AnsiChar);
end;
{ TTarWriter }
TTarWriter = class
private
FSourceStream,
FTargetStream: TFileStreamEx;
FWcxModule: TWcxModule;
FTarHeader: TTarHeaderEx;
FBasePath,
FTargetPath,
FArchiveFileName: String;
FBufferIn,
FBufferOut: Pointer;
FBufferSize: LongWord;
FMemPack: TArcHandle;
FLongName: array[0..Pred(LONGMAX)] of AnsiChar;
procedure WriteFakeHeader(const ItemName: String; IsFileName: Boolean; Offset: LongInt);
function MakeLongName(const FileName, LinkName: String;
NameLen, LinkLen: LongInt): LongInt;
function ReadData(BytesToRead: Int64): Int64;
procedure WriteData(Buffer: Pointer; BytesToWrite: Int64);
procedure CompressData(BufferIn: Pointer; BytesToCompress: Int64);
protected
AskQuestion: TAskQuestionFunction;
AbortOperation: TAbortOperationFunction;
CheckOperationState: TCheckOperationStateFunction;
UpdateStatistics: TUpdateStatisticsFunction;
DataWrite: TDataWriteProcedure;
procedure ShowError(sMessage: String);
procedure AddFile(const FileName: String);
function WriteFile(const FileName: String; var Statistics: TFileSourceCopyOperationStatistics): Boolean;
public
constructor Create(ArchiveFileName: String;
AskQuestionFunction: TAskQuestionFunction;
AbortOperationFunction: TAbortOperationFunction;
CheckOperationStateFunction: TCheckOperationStateFunction;
UpdateStatisticsFunction: TUpdateStatisticsFunction
);
constructor Create(ArchiveFileName: String;
AskQuestionFunction: TAskQuestionFunction;
AbortOperationFunction: TAbortOperationFunction;
CheckOperationStateFunction: TCheckOperationStateFunction;
UpdateStatisticsFunction: TUpdateStatisticsFunction;
WcxModule: TWcxModule
);
destructor Destroy; override;
function TarBegin: Boolean;
function TarFiles(const Files: TFiles; var Statistics: TFileSourceCopyOperationStatistics): Boolean;
function TarEnd(const beforeResult: Boolean): Boolean;
end;
implementation
uses
{$IF DEFINED(MSWINDOWS)}
Windows, DCFileAttributes, DCWindows, uMyWindows,
{$ELSEIF DEFINED(UNIX)}
BaseUnix, FileUtil, uUsersGroups,
{$ENDIF}
uLng, DCStrUtils, DCOSUtils, uOSUtils;
{$IF DEFINED(MSWINDOWS)}
const
FILE_UNIX_MODE = S_IRUSR or S_IWUSR or S_IRGRP or S_IROTH;
FOLDER_UNIX_MODE = S_IRUSR or S_IWUSR or S_IXUSR or S_IRGRP or S_IXGRP or S_IROTH or S_IXOTH;
{$ENDIF}
// Makes a string of octal digits
// The string will always be "Len" characters long
procedure Octal64(N : Int64; P : PAnsiChar; Len : Integer);
var
I : Integer;
begin
for I := Len - 1 downto 0 do
begin
(P + I)^ := AnsiChar (ORD ('0') + ORD (N and $07));
N := N shr 3;
end;
for I := 0 to Len - 1 do
begin
if (P + I)^ in ['0'..'7'] then Break;
(P + I)^ := '0';
end;
end;
procedure OctalN(N : Int64; P : PAnsiChar; Len : Integer);
begin
Octal64(N, P, Len-1);
(P + Len - 1)^ := #0;
end;
procedure CheckSum(var TarHeader: TTarHeaderEx);
var
I: Integer;
ChkSum : Cardinal = 0;
begin
with TarHeader do
begin
StrMove(HR.ChkSum, CHKBLANKS, 8);
for I := 0 to SizeOf(TTarHeader) - 1 do
Inc(ChkSum, Ord(HA[I]));
Octal64(ChkSum, HR.ChkSum, 6);
HR.ChkSum[6] := #0;
HR.ChkSum[7] := #32;
end;
end;
{$IF DEFINED(MSWINDOWS)}
function GetFileInfo(const FileName: String; out FileInfo: TWin32FindDataW): Boolean;
var
Handle: System.THandle;
begin
Handle := FindFirstFileW(PWideChar(UTF16LongName(FileName)), FileInfo);
Result := Handle <> INVALID_HANDLE_VALUE;
if Result then
begin
FileInfo.dwFileAttributes:= ExtractFileAttributes(FileInfo);
Windows.FindClose(Handle);
end;
end;
{$ELSEIF DEFINED(UNIX)}
function GetFileInfo(const FileName: String; out FileInfo: BaseUnix.Stat): Boolean;
begin
Result:= fpLStat(UTF8ToSys(FileName), FileInfo) >= 0;
end;
{$ENDIF}
{ TTarWriter }
procedure TTarWriter.ShowError(sMessage: String);
begin
AskQuestion(sMessage, '', [fsourAbort], fsourAbort, fsourAbort);
AbortOperation;
end;
constructor TTarWriter.Create(ArchiveFileName: String;
AskQuestionFunction: TAskQuestionFunction;
AbortOperationFunction: TAbortOperationFunction;
CheckOperationStateFunction: TCheckOperationStateFunction;
UpdateStatisticsFunction: TUpdateStatisticsFunction);
begin
AskQuestion := AskQuestionFunction;
AbortOperation := AbortOperationFunction;
CheckOperationState := CheckOperationStateFunction;
UpdateStatistics := UpdateStatisticsFunction;
DataWrite:= @WriteData;
FArchiveFileName:= ArchiveFileName;
FTargetPath:= ExtractFilePath(ArchiveFileName);
// Allocate buffers
FBufferSize := gCopyBlockSize;
GetMem(FBufferIn, FBufferSize);
FBufferOut:= nil;
FWcxModule:= nil;
FMemPack:= 0;
end;
constructor TTarWriter.Create(ArchiveFileName: String;
AskQuestionFunction: TAskQuestionFunction;
AbortOperationFunction: TAbortOperationFunction;
CheckOperationStateFunction: TCheckOperationStateFunction;
UpdateStatisticsFunction: TUpdateStatisticsFunction;
WcxModule: TWcxModule);
begin
AskQuestion := AskQuestionFunction;
AbortOperation := AbortOperationFunction;
CheckOperationState := CheckOperationStateFunction;
UpdateStatistics := UpdateStatisticsFunction;
DataWrite:= @CompressData;
FArchiveFileName:= ArchiveFileName;
FTargetPath:= ExtractFilePath(ArchiveFileName);
// Allocate buffers
FBufferSize := gCopyBlockSize;
GetMem(FBufferIn, FBufferSize);
GetMem(FBufferOut, FBufferSize);
FWcxModule:= WcxModule;
// Starts packing into memory
FMemPack:= FWcxModule.WcxStartMemPack(MEM_OPTIONS_WANTHEADERS, ExtractFileName(ArchiveFileName));
end;
destructor TTarWriter.Destroy;
begin
inherited Destroy;
if Assigned(FWcxModule) then
begin
// Ends packing into memory
if (FMemPack <> 0) then
FWcxModule.DoneMemPack(FMemPack);
end;
if Assigned(FBufferIn) then
begin
FreeMem(FBufferIn);
FBufferIn := nil;
end;
if Assigned(FBufferOut) then
begin
FreeMem(FBufferOut);
FBufferOut := nil;
end;
end;
procedure TTarWriter.AddFile(const FileName: String);
{$IF DEFINED(MSWINDOWS)}
var
FileInfo: TWin32FindDataW;
LinkName,
FileNameIn: String;
FileMode: Cardinal;
FileTime,
FileSize: Int64;
NameLen,
LinkLen: LongInt;
begin
if GetFileInfo(FileName, FileInfo) then
with FTarHeader do
begin
FillByte(HR, SizeOf(FTarHeader), 0);
// File name
FileNameIn:= ExtractDirLevel(FBasePath, FileName);
FileNameIn:= StringReplace (FileNameIn, '\', '/', [rfReplaceAll]);
if FPS_ISDIR(FileInfo.dwFileAttributes) then
FileNameIn:= FileNameIn + '/';
StrLCopy (HR.Name, PAnsiChar(FileNameIn), NAMSIZ);
// File mode
if FPS_ISDIR(FileInfo.dwFileAttributes) then
FileMode:= FOLDER_UNIX_MODE
else
FileMode:= FILE_UNIX_MODE;
OctalN(FileMode, HR.Mode, 8);
// File size
FileSize:= (FileInfo.nFileSizeHigh shl 32) or FileInfo.nFileSizeLow;
if FPS_ISLNK(FileInfo.dwFileAttributes) then
OctalN(0, HR.Size, 12)
else
OctalN(FileSize, HR.Size, 12);
// Modification time
FileTime:= Round((Int64(FileInfo.ftLastWriteTime) - 116444736000000000) / 10000000);
OctalN(FileTime, HR.MTime, 12);
// File type
if FPS_ISLNK(FileInfo.dwFileAttributes) then
HR.TypeFlag := '2'
else if FPS_ISDIR(FileInfo.dwFileAttributes) then
HR.TypeFlag := '5'
else
HR.TypeFlag := '0';
// Link name
if FPS_ISLNK(FileInfo.dwFileAttributes) then
begin
LinkName:= ReadSymLink(FileName);
StrLCopy(HR.LinkName, PAnsiChar(LinkName), NAMSIZ);
end;
// Magic
StrLCopy (HR.Magic, PAnsiChar(USTAR), 8);
// Header checksum
CheckSum(FTarHeader);
// Get file name and link name length
NameLen:= Length(FileNameIn);
LinkLen:= Length(LinkName);
// Write data
if not ((NameLen > NAMSIZ) or (LinkLen > NAMSIZ)) then
DataWrite(@HA, RECORDSIZE)
else
begin
NameLen:= MakeLongName(FileNameIn, LinkName, NameLen, LinkLen);
DataWrite(@FLongName, NameLen);
end;
end;
end;
{$ELSEIF DEFINED(UNIX)}
var
FileInfo: BaseUnix.Stat;
LinkName,
FileNameIn: String;
NameLen,
LinkLen: LongInt;
begin
if GetFileInfo(FileName, FileInfo) then
with FTarHeader do
begin
FillByte(HR, SizeOf(FTarHeader), 0);
// File name
FileNameIn:= ExtractDirLevel(FBasePath, FileName);
if fpS_ISDIR(FileInfo.st_mode) then
FileNameIn:= FileNameIn + PathDelim;
StrLCopy (HR.Name, PAnsiChar(FileNameIn), NAMSIZ);
// File mode
OctalN(FileInfo.st_mode and $FFF, HR.Mode, 8);
// UID
OctalN(FileInfo.st_uid, HR.UID, 8);
// GID
OctalN(FileInfo.st_gid, HR.GID, 8);
// File size
if fpS_ISLNK(FileInfo.st_mode) or fpS_ISDIR(FileInfo.st_mode) then
OctalN(0, HR.Size, 12)
else
OctalN(FileInfo.st_size, HR.Size, 12);
// Modification time
OctalN(FileInfo.st_mtime, HR.MTime, 12);
// File type
if fpS_ISLNK(FileInfo.st_mode) then
HR.TypeFlag:= '2'
else if fpS_ISCHR(FileInfo.st_mode) then
HR.TypeFlag:= '3'
else if fpS_ISBLK(FileInfo.st_mode) then
HR.TypeFlag:= '4'
else if fpS_ISDIR(FileInfo.st_mode) then
HR.TypeFlag:= '5'
else if fpS_ISFIFO(FileInfo.st_mode) then
HR.TypeFlag:= '6'
else
HR.TypeFlag:= '0';
// Link name
if fpS_ISLNK(FileInfo.st_mode) then
begin
LinkName:= ReadSymLink(FileName);
StrLCopy(HR.LinkName, PAnsiChar(LinkName), NAMSIZ);
end;
// Magic
StrLCopy (HR.Magic, PAnsiChar(USTAR), 8);
// User
StrPLCopy(HR.UName, UIDToStr(FileInfo.st_uid), TUNMLEN);
// Group
StrPLCopy(HR.GName, GIDToStr(FileInfo.st_gid), TGNMLEN);
// Header checksum
CheckSum(FTarHeader);
// Get file name and link name length
NameLen:= Length(FileNameIn);
LinkLen:= Length(LinkName);
// Write data
if not ((NameLen > NAMSIZ) or (LinkLen > NAMSIZ)) then
DataWrite(@HA, RECORDSIZE)
else
begin
NameLen:= MakeLongName(FileNameIn, LinkName, NameLen, LinkLen);
DataWrite(@FLongName, NameLen);
end;
end;
end;
{$ENDIF}
procedure TTarWriter.WriteFakeHeader(const ItemName: String;
IsFileName: Boolean; Offset: LongInt);
var
TarHeader: TTarHeaderEx;
begin
with TarHeader do
begin
FillByte(TarHeader, SizeOf(TTarHeaderEx), 0);
StrPLCopy (HR.Name, LONGLINK, NAMSIZ);
if IsFileName then
HR.TypeFlag:= 'L'
else
HR.TypeFlag:= 'K';
// File mode
OctalN(0, HR.Mode, 8);
// UID
OctalN(0, HR.UID, 8);
// GID
OctalN(0, HR.GID, 8);
// Name size
OctalN(Length(ItemName) + 1, HR.Size, 12);
// Modification time
OctalN(0, HR.MTime, 12);
// Magic
StrLCopy (HR.Magic, PAnsiChar(USTAR), 8);
// User
StrPLCopy(HR.UName, 'root', TUNMLEN);
// Group
StrPLCopy(HR.GName, 'root', TGNMLEN);
// Header checksum
CheckSum(TarHeader);
// Copy file record
Move(HA, PByte(PAnsiChar(@FLongName) + Offset)^, RECORDSIZE);
// Copy file name
StrMove(PAnsiChar(@FLongName) + Offset + RECORDSIZE, PAnsiChar(ItemName), Length(ItemName));
end;
end;
function TTarWriter.MakeLongName(const FileName, LinkName: String;
NameLen, LinkLen: LongInt): LongInt;
begin
with FTarHeader do
begin
Result:= 0;
// Strip string length to maximum length
if (NameLen + RECORDSIZE) > LONGLEN then
NameLen:= LONGLEN - RECORDSIZE * 2;
if (LinkLen + RECORDSIZE) > LONGLEN then
LinkLen:= LONGLEN - RECORDSIZE * 2;
// Clear output buffer
FillChar(FLongName, NameLen + LinkLen + RECORDSIZE * 4, #0);
// Write Header for long link name
if LinkLen > NAMSIZ then
begin
WriteFakeHeader(LinkName, False, Result);
// Align link name by RECORDSIZE (512)
if (LinkLen mod RECORDSIZE) = 0 then
Result:= Result + RECORDSIZE + Linklen
else
Result:= Result + RECORDSIZE * 2 + (LinkLen div RECORDSIZE) * RECORDSIZE;
end;
// Write Header for long file name
if NameLen > NAMSIZ then
begin
WriteFakeHeader(FileName, True, Result);
// Align file name by RECORDSIZE (512)
if (NameLen mod RECORDSIZE) = 0 then
Result:= Result + RECORDSIZE + NameLen
else
Result:= Result + RECORDSIZE * 2 + (NameLen div RECORDSIZE) * RECORDSIZE;
end;
// Copy file record
Move(HA, PByte(PAnsiChar(@FLongName) + Result)^, RECORDSIZE);
Result:= Result + RECORDSIZE;
end;
end;
function TTarWriter.ReadData(BytesToRead: Int64): Int64;
var
bRetryRead: Boolean;
BytesRead: Int64;
begin
repeat
try
bRetryRead := False;
FillByte(FBufferIn^, FBufferSize, 0);
BytesRead:= FSourceStream.Read(FBufferIn^, BytesToRead);
if (BytesRead = 0) then
Raise EReadError.Create(mbSysErrorMessage(GetLastOSError));
except
on E: EReadError do
begin
case AskQuestion(rsMsgErrERead + ' ' + FSourceStream.FileName + ':',
E.Message,
[fsourRetry, fsourSkip, fsourAbort],
fsourRetry, fsourSkip) of
fsourRetry:
bRetryRead := True;
fsourAbort:
AbortOperation;
fsourSkip:
Exit;
end; // case
end;
end;
until not bRetryRead;
Result:= BytesRead;
end;
procedure TTarWriter.WriteData(Buffer: Pointer; BytesToWrite: Int64);
var
iTotalDiskSize, iFreeDiskSize: Int64;
bRetryWrite: Boolean;
BytesWrittenTry, BytesWritten: Int64;
begin
BytesWritten := 0;
repeat
try
bRetryWrite := False;
BytesWrittenTry := FTargetStream.Write((Buffer + BytesWritten)^, BytesToWrite - BytesWritten);
BytesWritten := BytesWritten + BytesWrittenTry;
if BytesWrittenTry = 0 then
begin
Raise EWriteError.Create(mbSysErrorMessage(GetLastOSError));
end
else if BytesWritten < BytesToWrite then
begin
bRetryWrite := True; // repeat and try to write the rest
end;
except
on E: EWriteError do
begin
{ Check disk free space }
GetDiskFreeSpace(FTargetPath, iFreeDiskSize, iTotalDiskSize);
if BytesToWrite > iFreeDiskSize then
begin
case AskQuestion(rsMsgNoFreeSpaceRetry, '',
[fsourYes, fsourNo],
fsourYes, fsourNo) of
fsourYes:
bRetryWrite := True;
fsourNo:
AbortOperation;
end; // case
end
else
begin
case AskQuestion(rsMsgErrEWrite + ' ' + FArchiveFileName + ':',
E.Message,
[fsourRetry, fsourSkip, fsourAbort],
fsourRetry, fsourSkip) of
fsourRetry:
bRetryWrite := True;
fsourAbort:
AbortOperation;
fsourSkip:
Exit;
end; // case
end;
end; // on do
end; // except
until not bRetryWrite;
end;
procedure TTarWriter.CompressData(BufferIn: Pointer; BytesToCompress: Int64);
var
InLen: LongInt;
Written: LongInt = 0;
Taken: LongInt = 0;
SeekBy: LongInt = 0;
OffSet: LongInt = 0;
Result: LongInt;
begin
InLen:= BytesToCompress;
// Do while not all data accepted
repeat
// Recalculate offset
if (Taken <> 0) then
begin
OffSet:= OffSet + Taken;
InLen:= InLen - Taken;
end;
// Compress input buffer
{$PUSH}{$WARNINGS OFF}
Result:= FWcxModule.PackToMem(FMemPack, PByte(PtrUInt(BufferIn) + OffSet), InLen, @Taken, FBufferOut, FBufferSize, @Written, @SeekBy);
{$POP}
if not (Result in [MEMPACK_OK, MEMPACK_DONE]) then
begin
ShowError(Format(rsMsgLogError + rsMsgLogPack,
[FArchiveFileName + ' - ' + GetErrorMsg(Result)]));
end;
// Seek if needed
if (SeekBy <> 0) then
FTargetStream.Seek(SeekBy, soCurrent);
// Write compressed data
if Written > 0 then
WriteData(FBufferOut, Written);
until ((Taken = InLen) and (BytesToCompress <> 0)) or (Result = MEMPACK_DONE);
end;
function TTarWriter.WriteFile(const FileName: String; var Statistics: TFileSourceCopyOperationStatistics): Boolean;
var
BytesRead, BytesToRead, BytesToWrite: Int64;
TotalBytesToRead: Int64 = 0;
begin
Result := False;
BytesToRead := FBufferSize;
try
FSourceStream:= nil;
try
FSourceStream := TFileStreamEx.Create(FileName, fmOpenRead or fmShareDenyWrite);
TotalBytesToRead := FSourceStream.Size;
while TotalBytesToRead > 0 do
begin
// Without the following line the reading is very slow
// if it tries to read past end of file.
if TotalBytesToRead < BytesToRead then
BytesToRead := TotalBytesToRead;
BytesRead:= ReadData(BytesToRead);
TotalBytesToRead := TotalBytesToRead - BytesRead;
BytesToWrite:= BytesRead;
if (BytesRead mod RECORDSIZE) <> 0 then
begin
// Align by TAR RECORDSIZE
BytesToWrite:= (BytesRead div RECORDSIZE) * RECORDSIZE + RECORDSIZE;
end;
// Write data
DataWrite(FBufferIn, BytesToWrite);
with Statistics do
begin
CurrentFileDoneBytes := CurrentFileDoneBytes + BytesRead;
DoneBytes := DoneBytes + BytesRead;
UpdateStatistics(Statistics);
end;
CheckOperationState; // check pause and stop
end; // while
finally
FreeAndNil(FSourceStream);
end;
Result:= True;
except
on EFOpenError do
begin
ShowError(rsMsgLogError + rsMsgErrEOpen + ': ' + FileName);
end;
on EWriteError do
begin
ShowError(rsMsgLogError + rsMsgErrEWrite + ': ' + FArchiveFileName);
end;
end;
end;
function TTarWriter.TarBegin: Boolean;
begin
Result:= False;
try
FTargetStream:= TFileStreamEx.Create(FArchiveFileName, fmCreate);
Result:= True;
except
on EFCreateError do
begin
ShowError(rsMsgLogError + rsMsgErrECreate + ': ' + FArchiveFileName);
end;
end;
end;
function TTarWriter.TarFiles(
const Files: TFiles;
var Statistics: TFileSourceCopyOperationStatistics): Boolean;
var
aFile: TFile;
Divider: Int64 = 1;
CurrentFileIndex: Integer;
iTotalDiskSize, iFreeDiskSize: Int64;
procedure initCurrentTar;
begin
// Set base path
FBasePath:= Files.Path;
if FMemPack = 0 then begin
Divider:= 2;
end;
// Update progress
with Statistics do
begin
CurrentFileTo:= FArchiveFileName;
TotalBytes:= TotalBytes * Divider;
UpdateStatistics(Statistics);
end;
// initCurrentTar disk free space
//if FCheckFreeSpace = True then
begin
GetDiskFreeSpace(FTargetPath, iFreeDiskSize, iTotalDiskSize);
if Statistics.TotalBytes > iFreeDiskSize then
begin
AskQuestion('', rsMsgNoFreeSpaceCont, [fsourAbort], fsourAbort, fsourAbort);
AbortOperation;
end;
end;
end;
begin
Result:= False;
initCurrentTar;
for CurrentFileIndex := 0 to Files.Count - 1 do begin
aFile := Files[CurrentFileIndex];
if aFile.IsDirectory or aFile.IsLink then begin
// Add file record only
AddFile(aFile.FullPath);
end else begin
// Update progress
with Statistics do
begin
CurrentFileFrom := aFile.FullPath;
CurrentFileTotalBytes := aFile.Size;
CurrentFileDoneBytes := 0;
end;
UpdateStatistics(Statistics);
// Add file record
AddFile(aFile.FullPath);
// TAR current file
if not WriteFile(aFile.FullPath, Statistics) then
Exit;
end;
CheckOperationState;
end;
Result:= True;
end;
function TTarWriter.TarEnd(const beforeResult: Boolean): Boolean;
begin
Result:= False;
try
// Finish TAR archive with two null records
FillByte(FBufferIn^, RECORDSIZE * 2, 0);
DataWrite(FBufferIn, RECORDSIZE * 2);
// Finish compression if needed
if (FMemPack <> 0) then CompressData(FBufferIn, 0);
Result:= beforeResult;
finally
if Assigned(FTargetStream) then begin
FreeAndNil(FTargetStream);
if NOT Result then begin
// There was some error, because not all files has been archived.
// Delete the not completed target file.
mbDeleteFile(FArchiveFileName)
end;
end;
end;
end;
end.
Reference in a new issue View git blame Copy permalink