use File::Copy ();
use File::Temp ();
use File::Path ();
+use File::Spec;
use File::Spec::Functions;
-use Archive::Extract;
use IO::Uncompress::Gunzip ();
use File::Compare ();
use ExtUtils::Manifest;
use lib 'Porting';
use Maintainers ();
-# if running from blead, we may be doing -Ilib, which means when we
-# 'chdir /tmp/foo', Archive::Extract may not find Archive::Tar etc.
-# So preload the things we need, and tell it to check %INC first:
-
use Archive::Tar;
+use Cwd qw[cwd chdir];
use IPC::Open3;
use IO::Select;
-$Module::Load::Conditional::CHECK_INC_HASH = 1;
-
-# stop Archive::Extract whinging about lack of Archive::Zip
-$Archive::Extract::WARN = 0;
+local $Archive::Tar::WARN=0;
# where, under the cache dir, to download tarballs to
use constant SRC_DIR => 'tarballs';
'x|crosscheck' => \$do_crosscheck,
) or usage;
- @wanted_upstreams = map { $_ eq 'undef' ? undef : $_ } @wanted_upstreams;
-
my @modules;
usage("Cannot mix -a with module list") if $scan_all && @ARGV;
}
if ( defined $cache_dir ) {
- die "ERROR: no such directory: '$cache_dir'\n" unless -d $cache_dir;
+ die "ERROR: not a directory: '$cache_dir'\n"
+ if !-d $cache_dir && -e $cache_dir;
+ File::Path::mkpath($cache_dir);
}
else {
$cache_dir = File::Temp::tempdir( CLEANUP => 1 );
}
my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
+ my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
my %seen_dist;
for my $module (@$modules) {
warn "WARNING: duplicate entry for $dist in $module\n";
}
- my $upstream = $m->{UPSTREAM};
- next if @$wanted_upstreams and !( $upstream ~~ $wanted_upstreams );
+ my $upstream = $m->{UPSTREAM} // 'undef';
+ next if @$wanted_upstreams and !$wanted_upstream{$upstream};
print $outfh "\n$module - "
. $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
$distros{ distro_base($short_distro) }{$distro} = 1;
}
+ my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
for my $module (@$modules) {
my $m = $Maintainers::Modules{$module}
or die "ERROR: No such module in Maintainers.pl: '$module'\n";
my $pdist = $m->{DISTRIBUTION};
die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
- my $upstream = $m->{UPSTREAM};
- next if @$wanted_upstreams and !( $upstream ~~ $wanted_upstreams );
+ my $upstream = $m->{UPSTREAM} // 'undef';
+ next if @$wanted_upstreams and !$wanted_upstream{$upstream};
my $cdist = $modules{$module};
( my $short_pdist = $pdist ) =~ s{^.*/}{};
}
# get the EXCLUDED and MAP entries for this module, or
-# make up defauts if they don't exist
+# make up defaults if they don't exist
sub get_map {
my ( $m, $module_name, $perl_files ) = @_;
sub cpan_to_perl {
my ( $excluded, $map, $customized, $cpan_file ) = @_;
+ my %customized = map { ( $_ => 1 ) } @$customized;
for my $exclude (@$excluded) {
- next if $exclude ~~ $customized;
+ next if $customized{$exclude};
# may be a simple string to match exactly, or a pattern
if ( ref $exclude ) {
# extract it unless we already have it cached or tarball is newer
if ( !-d $path || ( -M $download_file < -M $path ) ) {
- my $ae = Archive::Extract->new( archive => $download_file );
- $ae->extract( to => $untar_dir )
+ $path = extract( $download_file, $untar_dir )
or die
"ERROR: failed to extract distribution '$download_file to temp. dir: "
- . $ae->error() . "\n";
-
- $path = $ae->extract_path;
+ . $! . "\n";
}
die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
}
+sub extract {
+ my ($archive,$to) = @_;
+ my $cwd = cwd();
+ chdir $to or die "$!\n";
+ my @files;
+ EXTRACT: {
+ local $Archive::Tar::CHOWN = 0;
+ my $next;
+ unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
+ $! = $Archive::Tar::error;
+ last EXTRACT;
+ }
+ while ( my $file = $next->() ) {
+ push @files, $file->full_path;
+ unless ( $file->extract ) {
+ $! = $Archive::Tar::error;
+ last EXTRACT;
+ }
+ }
+ }
+ my $path = __get_extract_dir( \@files );
+ chdir $cwd or die "$!\n";
+ return $path;
+}
+
+sub __get_extract_dir {
+ my $files = shift || [];
+
+ return unless scalar @$files;
+
+ my($dir1, $dir2);
+ for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
+ my($dir,$pos) = @$aref;
+
+ ### add a catdir(), so that any trailing slashes get
+ ### take care of (removed)
+ ### also, a catdir() normalises './dir/foo' to 'dir/foo';
+ ### which was the problem in bug #23999
+ my $res = -d $files->[$pos]
+ ? File::Spec->catdir( $files->[$pos], '' )
+ : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
+
+ $$dir = $res;
+ }
+
+ ### if the first and last dir don't match, make sure the
+ ### dirname is not set wrongly
+ my $dir;
+
+ ### dirs are the same, so we know for sure what the extract dir is
+ if( $dir1 eq $dir2 ) {
+ $dir = $dir1;
+
+ ### dirs are different.. do they share the base dir?
+ ### if so, use that, if not, fall back to '.'
+ } else {
+ my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
+ my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
+
+ $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
+ }
+
+ return File::Spec->rel2abs( $dir );
+}
+
run();