use warnings;
use strict;
use Archive::Tar;
$Archive::Tar::DO_NOT_USE_PREFIX = 1;
=head1 NAME
fix.pl
=head1 DESCRIPTION
This code found at http://perlmonks.org/index.pl?node_id=731935
via PAUSE's reports of failed uploads.
The author wrote:
I found it way too hard to try to make Getopt::Std and Getopt::Long
behave as I'd like It's much easier to just implement command line
options parsing by h and... Careful: you cannot combine several
single letter command line optio ns into one, They must stay separate.
I have removed command line options: the script now just takes
the path to a tarball to fix.
=cut
# DISTVNAME
while(@ARGV) {
my $dist = shift;
$dist =~ /\.t(ar\.)?gz$/
or die "Wrong argument: '$dist'; please provide a '.tar.gz' file as argument";
print "Loading distribution '$dist'\n";
my $fixes;
my $tar = Archive::Tar->new;
if (not $tar->read($dist)){
warn "Have you run make tardist?\n";
next;
}
my @files = $tar->get_files;
foreach my $file (@files) {
my $fixedmode = my $mode = $file->mode;
my $filetype = '';
if($file->is_file) {
$filetype = 'file';
if(substr(${ $file->get_content_by_ref }, 0, 2) eq '#!') {
$fixedmode = $ENV{PERM_RW}? '0'.$ENV{PERM_RW} : 0775;
} else {
$fixedmode = $ENV{PERM_RWX}? '0'.$ENV{PERM_RWX} : 0664;
}
}
elsif($file->is_dir) {
$filetype = 'dir';
$fixedmode = $ENV{PERM_RW}? '0'.$ENV{PERM_RW} : 0775;;
}
else {
next;
}
next if $mode eq $fixedmode;
$file->mode($fixedmode);
$fixes++;
printf "Change mode %03o to %03o for %s '%s'\n", $mode, $fixedmode, $filetype, $file->name;
}
if ($fixes) {
rename $dist, "$dist.bak" or die "Cannot rename file '$dist' to '$dist.bak': $!";
$tar->write($dist, 9);
print "File '$dist' saved.\n";
} else {
print "File '$dist' didn't need fixing, skipped.\n";
}
}