1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
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;
}
|
GitWeb