tar-transform-names.pl: new tool to do stream modification of tarball

Signed-off-by: Robin H. Johnson <robbat2@gentoo.org>

1 files changed, 80 insertions, 0 deletions

diff --git a/tar-transform-names.pl b/tar-transform-names.pl
new file mode 100755
index 0000000..9bc0fd6
--- /dev/null
+++ b/tar-transform-names.pl
@@ -0,0 +1,80 @@
+#!/usr/bin/perl -w
+# Copyright 2019 Gentoo Authors; Distributed under the GPL v2
+# Trivial tool to modify the path strings of files in a tarball, WITHOUT
+# unpacking the tarball.
+use strict;
+use warnings;
+#use re 'strict'; # This fails if the modifiers are empty
+use Getopt::Long;
+use File::Temp qw/tempfile/;
+use File::Basename;
+use Archive::Tar::Stream;
+
+my $input_filename;
+my $output_filename;
+my $regex;
+my $verbose = 0;
+#my ($t, $t2, $r);
+
+GetOptions(
+	"i|input-filename=s" => \$input_filename,
+	"o|output-filename=s" => \$output_filename,
+	"r|regex-replacement=s" => \$regex,
+	"v|verbose" => \$verbose,
+	#"t|test-string=s" => \$t,
+) or die("Error in args");
+
+die("--input-filename=... is required") unless -e $input_filename;
+die("--output-filename=... is required") unless defined $output_filename;
+die("--regex=... is required") unless defined $regex;
+$regex =~ /^(?<op>s)(?<sep>.)(?<match>.*)\g{sep}(?<replacement>.*)\g{sep}(?<mod>[a-zA-Z0-9]*)$/;
+my $regex_op = $+{op};
+my $regex_match = $+{match};
+my $regex_replacement = $+{replacement};
+my $regex_mod = $+{mod};
+die("--regex=$regex is not valid") unless defined $regex_op and defined $regex_match and defined $regex_replacement and defined $regex_mod;
+die "Refusing unsafe/unknown regex modifiers" unless $regex_mod=~/^[msixpodualng]*$/;
+
+die("Refusing to overwrite") if $input_filename eq $output_filename;
+
+#printf "op %s\n", $regex_op;
+#printf "match %s\n", $regex_match;
+#printf "replacement %s\n", $regex_replacement;
+#printf "mod %s\n", $regex_mod;
+
+#my $infh = IO::File->new("zcat $infile |") || die "oops";
+#my $outfh = IO::File->new("| gzip > $outfile") || die "double oops";
+open(my $infh, '<', $input_filename);
+my ($outfh, $temp_filename) = tempfile(
+	sprintf('.%s.XXXXXXXX', basename($output_filename)),
+	DIR => dirname($output_filename),
+	UNLINK => 1,
+);
+
+
+my $ts = Archive::Tar::Stream->new(infh => $infh, outfh => $outfh);
+my $success = 0;
+$Archive::Tar::Stream::VERBOSE = $verbose;
+$ts->StreamCopy(sub {
+    my ($header, $outpos, $fh) = @_;
+
+	$header->{name} =~ s/(?${regex_mod})${regex_match}/${regex_replacement}/;
+	#printf "%s => %s\n", $header->{name}, $newheader->{name};
+
+	return 'KEEP', $header;
+});
+$success = 1;
+
+close($infh);
+
+END {
+	if($success == 1) {
+		rename $temp_filename, $output_filename or do {
+			unlink $temp_filename;
+			die("Failed to rename temporary file to destination name");
+		}
+	}
+	# Cleanup in other case
+	unlink $temp_filename if -e $temp_filename;
+	close $outfh;
+}