include "tar.s7i";
include "osfiles.s7i";
include "fileutil.s7i";
include "gzip.s7i";
include "bzip2.s7i";
include "lzma.s7i";
include "xz.s7i";
include "zstd.s7i";
include "archive.s7i";
const proc: setUpHead (in string: basePath, in string: filePath,
in string: filePathSuffix, inout tarHeader: header) is func
begin
header.name := (filePath & filePathSuffix)[.. 100];
header.mode := integer(getFileMode(basePath & filePath));
header.uid := 100;
header.gid := 100;
header.fileSize := 0;
header.mtime := timestamp1970(getMTime(basePath & filePath));
header.chksum := 0;
header.typeflag := REGTYPE;
header.linkname := "";
header.magic := TAR_MAGIC;
header.version := " ";
header.uname := "";
header.gname := "";
header.devmajor := 0;
header.devminor := 0;
header.prefix := "";
header.filePath := filePath;
header.filePathSuffix := filePathSuffix;
end func;
const func file: openTarFileWithMagic (in string: inFileName,
in boolean: complainIfUncompressed) is func
result
var file: inFile is STD_NULL;
local
var string: magicBytes is "";
begin
inFile := open(inFileName, "r");
if inFile <> STD_NULL then
magicBytes := gets(inFile, length(GZIP_MAGIC));
if magicBytes = GZIP_MAGIC then
seek(inFile, 1);
inFile := openGzipFile(inFile, READ);
else
magicBytes &:= gets(inFile, length(BZIP2_MAGIC) - length(GZIP_MAGIC));
if magicBytes = BZIP2_MAGIC then
seek(inFile, 1);
inFile := openBzip2File(inFile, READ);
else
magicBytes &:= gets(inFile, length(ZSTD_MAGIC) - length(BZIP2_MAGIC));
if magicBytes = ZSTD_MAGIC then
seek(inFile, 1);
inFile := openZstdFile(inFile);
else
magicBytes &:= gets(inFile, length(XZ_MAGIC) - length(ZSTD_MAGIC));
if magicBytes = XZ_MAGIC then
seek(inFile, 1);
inFile := openXzFile(inFile);
elsif endsWith(inFileName, ".lzma") then
seek(inFile, 1);
inFile := openLzmaFile(inFile);
else
magicBytes &:= gets(inFile, 262 - length(XZ_MAGIC));
if length(magicBytes) = 262 and
endsWith(magicBytes, TAR_MAGIC) then
seek(inFile, 1);
if complainIfUncompressed then
writeln("tar7: File \"" <& inFileName <&
"\" not in gzip, bzip2, xz, zstd or lzma format.");
end if;
else
close(inFile);
inFile := STD_NULL;
end if;
end if;
end if;
end if;
end if;
end if;
end func;
const func boolean: filePathIsInTarMemberList (in string: filePath,
in array string: memberList) is func
result
var boolean: isInMemberList is TRUE;
local
var string: member is "";
begin
if length(memberList) <> 0 then
isInMemberList := FALSE;
for member range memberList until isInMemberList do
if filePath = member or
(startsWith(filePath, member) and filePath[succ(length(member))] = '/') then
isInMemberList := TRUE;
end if;
end for;
end if;
end func;
const proc: tarTell (inout file: inFile, in array string: memberList,
in boolean: doView) is func
local
var tarHeader: header is tarHeader.value;
var time: modTime is time.value;
begin
readHead(inFile, header);
while not header.endOfFileMarker and
header.chksumOkay and header.filePath <> "" and
(header.magic = TAR_MAGIC or header.magic = TAR_NOMAGIC) do
if filePathIsInTarMemberList(header.filePath, memberList) then
if doView then
case header.typeflag of
when {REGTYPE, AREGTYPE}: write("-");
when {SYMTYPE}: write("l");
when {CHRTYPE}: write("c");
when {BLKTYPE}: write("b");
when {DIRTYPE}: write("d");
when {FIFOTYPE}: write("f");
otherwise: write("?");
end case;
write(fileMode(header.mode mod 8#1000) <& " ");
write(header.uname <> "" ? header.uname : str(header.uid) <& "/");
write(header.gname <> "" ? header.gname : str(header.gid));
write(header.fileSize lpad 14 <& " ");
modTime := timestamp1970ToTime(header.mtime);
write(strDate(modTime) <& " " <& str_hh_mm(modTime, ":") <& " ");
end if;
writeln(header.filePath <& header.filePathSuffix);
end if;
if header.fileSize <> 0 then
seek(inFile, tell(inFile) + succ(pred(header.fileSize) mdiv TAR_BLOCK_SIZE) * TAR_BLOCK_SIZE);
end if;
readHead(inFile, header);
end while;
if not header.endOfFileMarker then
if header.magic <> TAR_MAGIC and header.magic <> TAR_NOMAGIC then
writeln("*** The magic number of a tar header is not okay");
elsif not header.chksumOkay then
writeln("*** The check-sum of a tar header is not okay");
end if;
end if;
end func;
const proc: archiveTell (inout fileSys: archive, in array string: memberList,
in boolean: doView) is func
local
const string: fileTypeIndicator is " ?-dcbfls";
var array string: nameList is 0 times "";
var string: filePath is "";
var fileType: filType is FILE_ABSENT;
var time: modTime is time.value;
begin
nameList := readDir(archive, RECURSIVE);
for filePath range nameList do
if filePathIsInTarMemberList(filePath, memberList) then
if doView then
filType := fileTypeSL(archive, filePath);
write(fileTypeIndicator[succ(filType)]);
write(getFileMode(archive, filePath) <& " ");
write(getOwner(archive, filePath) <& "/");
write(getGroup(archive, filePath) <& " ");
write(fileSize(archive, filePath) lpad 14 <& " ");
modTime := getMTime(archive, filePath);
write(strDate(modTime) <& " " <& str_hh_mm(modTime, ":") <& " ");
end if;
writeln(filePath <& filType = FILE_DIR ? "/" : "");
end if;
end for;
end func;
const proc: tarTell (in string: inFileName, in array string: memberList,
in boolean: doView, in boolean: complainIfUncompressed) is func
local
var file: inFile is STD_NULL;
var fileSys: archive is fileSys.value;
begin
inFile := openTarFileWithMagic(inFileName, complainIfUncompressed);
if inFile <> STD_NULL then
tarTell(inFile, memberList, doView);
else
archive := openArchive(inFileName);
if archive <> fileSys.value then
archiveTell(archive, memberList, doView);
else
writeln("tar7: Cannot open \"" <& inFileName <& "\".");
end if;
end if;
end func;
const proc: tarXtract (inout file: inFile, in array string: memberList,
in boolean: doView) is func
local
var tarHeader: header is tarHeader.value;
var file: aFile is STD_NULL;
var integer: bytesCopied is 0;
var time: modTime is time.value;
var array tarHeader: dirHeaderList is 0 times tarHeader.value;
var integer: index is 0;
var boolean: okay is TRUE;
begin
readHead(inFile, header);
while not header.endOfFileMarker and
header.chksumOkay and header.filePath <> "" and
(header.magic = TAR_MAGIC or header.magic = TAR_NOMAGIC) and okay do
if filePathIsInTarMemberList(header.filePath, memberList) then
if doView then
write("x ");
writeln(header.filePath <& header.filePathSuffix);
end if;
if header.typeflag = DIRTYPE then
if fileTypeSL(header.filePath) = FILE_DIR then
dirHeaderList &:= [] (header);
elsif fileTypeSL(header.filePath) = FILE_ABSENT then
makeParentDirs(header.filePath);
makeDir(header.filePath);
dirHeaderList &:= [] (header);
else
writeln("*** The file " <& literal(header.filePath) <& " exists, but is not a directory");
okay := FALSE;
end if;
elsif header.typeflag = REGTYPE or header.typeflag = AREGTYPE then
if fileTypeSL(header.filePath) = FILE_REGULAR then
removeFile(header.filePath);
end if;
if fileTypeSL(header.filePath) = FILE_ABSENT then
makeParentDirs(header.filePath);
aFile := open(header.filePath, "w");
if aFile <> STD_NULL then
bytesCopied := copyFile(inFile, aFile, header.fileSize);
close(aFile);
setFileMode(header.filePath, fileMode(header.mode mod 8#1000));
modTime := timestamp1970ToTime(header.mtime);
setMTime(header.filePath, modTime);
skip(inFile, header.fileSize - bytesCopied +
pred(TAR_BLOCK_SIZE) - pred(header.fileSize) mod TAR_BLOCK_SIZE);
else
skip(inFile, succ(pred(header.fileSize) mdiv TAR_BLOCK_SIZE) * TAR_BLOCK_SIZE);
writeln("*** Cannot create file " <& literal(header.filePath));
okay := FALSE;
end if;
else
skip(inFile, succ(pred(header.fileSize) mdiv TAR_BLOCK_SIZE) * TAR_BLOCK_SIZE);
writeln("*** The file " <& literal(header.filePath) <& " exists, but is not a regular file");
okay := FALSE;
end if;
elsif header.typeflag = SYMTYPE then
if fileTypeSL(header.filePath) = FILE_SYMLINK then
removeFile(header.filePath);
end if;
if fileTypeSL(header.filePath) = FILE_ABSENT then
makeParentDirs(header.filePath);
if succeeds(makeLink(header.filePath, header.linkPath)) then
modTime := timestamp1970ToTime(header.mtime);
setMTime(header.filePath, modTime, SYMLINK);
else
writeln("*** Cannot create symbolic link " <& literal(header.filePath));
okay := FALSE;
end if;
else
writeln("*** The file " <& literal(header.filePath) <& " exists, but is not a symbolic link");
okay := FALSE;
end if;
else
writeln("*** Cannot create " <& literal(header.filePath));
end if;
end if;
readHead(inFile, header);
end while;
if not header.endOfFileMarker then
if header.magic <> TAR_MAGIC and header.magic <> TAR_NOMAGIC then
writeln("*** The magic number of a tar header is not okay");
elsif not header.chksumOkay then
writeln("*** The check-sum of a tar header is not okay");
end if;
end if;
for index range length(dirHeaderList) downto 1 do
setFileMode(dirHeaderList[index].filePath, fileMode(dirHeaderList[index].mode mod 8#1000));
modTime := timestamp1970ToTime(dirHeaderList[index].mtime);
setMTime(dirHeaderList[index].filePath, modTime);
end for;
end func;
const proc: archiveXtract (inout fileSys: archive, in array string: memberList,
in boolean: doView) is func
local
var array string: nameList is 0 times "";
var string: filePath is "";
var fileType: filType is FILE_ABSENT;
var array string: dirPathList is 0 times "";
var file: aFile is STD_NULL;
var integer: index is 0;
var boolean: okay is TRUE;
begin
nameList := readDir(archive, RECURSIVE);
for filePath range nameList until not okay do
if filePathIsInTarMemberList(filePath, memberList) then
filType := fileTypeSL(archive, filePath);
if doView then
write("x ");
writeln(filePath <& filType = FILE_DIR ? "/" : "");
end if;
if filType = FILE_DIR then
if fileTypeSL(filePath) = FILE_DIR then
dirPathList &:= [] (filePath);
elsif fileTypeSL(filePath) = FILE_ABSENT then
makeParentDirs(filePath);
makeDir(filePath);
dirPathList &:= [] (filePath);
else
writeln("*** The file " <& literal(filePath) <& " exists, but is not a directory");
okay := FALSE;
end if;
elsif filType = FILE_REGULAR then
if fileTypeSL(filePath) = FILE_REGULAR then
removeFile(filePath);
end if;
if fileTypeSL(filePath) = FILE_ABSENT then
makeParentDirs(filePath);
aFile := open(filePath, "w");
if aFile <> STD_NULL then
write(aFile, getFile(archive, filePath));
close(aFile);
setFileMode(filePath, getFileMode(archive, filePath));
setMTime(filePath, getMTime(archive, filePath));
else
writeln("*** Cannot create file " <& literal(filePath));
okay := FALSE;
end if;
else
writeln("*** The file " <& literal(filePath) <& " exists, but is not a regular file");
okay := FALSE;
end if;
elsif filType = FILE_SYMLINK then
if fileTypeSL(filePath) = FILE_SYMLINK then
removeFile(filePath);
end if;
if fileTypeSL(filePath) = FILE_ABSENT then
makeParentDirs(filePath);
if succeeds(makeLink(filePath, readLink(archive, filePath))) then
setMTime(filePath, getMTime(archive, filePath, SYMLINK), SYMLINK);
else
writeln("*** Cannot create symbolic link " <& literal(filePath));
okay := FALSE;
end if;
else
writeln("*** The file " <& literal(filePath) <& " exists, but is not a symbolic link");
okay := FALSE;
end if;
else
writeln("*** Cannot create " <& literal(filePath));
end if;
end if;
end for;
for index range length(dirPathList) downto 1 do
setFileMode(dirPathList[index], getFileMode(archive, dirPathList[index]));
setMTime(dirPathList[index], getMTime(archive, dirPathList[index]));
end for;
end func;
const proc: tarXtract (in string: inFileName, in array string: memberList,
in boolean: doView, in boolean: complainIfUncompressed) is func
local
var file: inFile is STD_NULL;
var fileSys: archive is fileSys.value;
begin
inFile := openTarFileWithMagic(inFileName, complainIfUncompressed);
if inFile <> STD_NULL then
tarXtract(inFile, memberList, doView);
else
archive := openArchive(inFileName);
if archive <> fileSys.value then
archiveXtract(archive, memberList, doView);
else
writeln("tar7: Cannot open \"" <& inFileName <& "\".");
end if;
end if;
end func;
const proc: tarXtract (in string: inFileName, in boolean: doView) is func
begin
tarXtract(inFileName, 0 times "", doView, FALSE);
end func;
const proc: tarXtract (in string: inFileName) is func
begin
tarXtract(inFileName, 0 times "", FALSE, FALSE);
end func;
const proc: tarCreate (inout file: outFile, in string: basePath, in string: pathFromBase,
in array string: fileList, in boolean: doView) is func
local
var string: name is "";
var array string: dirContent is 0 times "";
var file: aFile is STD_NULL;
var integer: bytesCopied is 0;
var tarHeader: header is tarHeader.value;
begin
for name range fileList do
name := pathFromBase & name;
if fileType(basePath & name) = FILE_ABSENT then
writeln("*** The file " <& literal(basePath & name) <& " does not exist.");
else
if doView then
write("c ");
writeln(name);
end if;
if fileType(basePath & name) = FILE_DIR then
dirContent := readDir(basePath & name);
setUpHead(basePath, name, "/", header);
header.typeflag := DIRTYPE;
writeHead(outFile, header);
tarCreate(outFile, basePath, name & "/", dirContent, doView);
else
setUpHead(basePath, name, "", header);
aFile := open(basePath & name, "r");
if aFile <> STD_NULL then
header.fileSize := length(aFile);
writeHead(outFile, header);
bytesCopied := copyFile(aFile, outFile, header.fileSize);
write(outFile, "\0;" mult header.fileSize - bytesCopied +
pred(TAR_BLOCK_SIZE) - pred(header.fileSize) mod TAR_BLOCK_SIZE);
close(aFile);
else
writeHead(outFile, header);
end if;
end if;
end if;
end for;
end func;
const proc: tarCreate (in string: outFileName, in array string: fileList,
in boolean: doView, in boolean: doZip) is func
local
var file: outFile is STD_NULL;
var file: compressedFile is STD_NULL;
var string: name is "";
var string: uncompressed is "";
begin
outFile := open(outFileName, "w");
if outFile <> STD_NULL and doZip then
compressedFile := outFile;
outFile := openGzipFile(compressedFile, WRITE);
end if;
if outFile <> STD_NULL then
for name range fileList do
tarCreate(outFile, "", "", [] name, doView);
end for;
write(outFile, END_OF_FILE_MARKER mult 2);
close(outFile);
end if;
if compressedFile <> STD_NULL then
close(compressedFile);
end if;
end func;
const proc: tarCreate (in string: outFileName, in array string: fileList,
in boolean: doView) is func
begin
tarCreate(outFileName, fileList, doView, FALSE);
end func;
const proc: tarCreate (in string: outFileName, in array string: fileList) is func
begin
tarCreate(outFileName, fileList, FALSE, FALSE);
end func;