X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4109bc0cd01be0ee6d8953b0e2c4f1638369a06e..7db8c4f1f19e6f855107ec990507a1a9cb0f59a6:/Porting/core-cpan-diff diff --git a/Porting/core-cpan-diff b/Porting/core-cpan-diff index b290941..23ae99f 100644 --- a/Porting/core-cpan-diff +++ b/Porting/core-cpan-diff @@ -14,8 +14,8 @@ use File::Basename (); 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; @@ -26,17 +26,11 @@ BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' } 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'; @@ -45,7 +39,6 @@ use constant SRC_DIR => 'tarballs'; use constant UNTAR_DIR => 'untarred'; use constant DIFF_CMD => 'diff'; -use constant WGET_CMD => 'wget'; sub usage { print STDERR "\n@_\n\n" if @_; @@ -59,9 +52,8 @@ Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ] -d/--diff Display file differences using diff(1), rather than just listing which files have changed. - The diff(1) command is assumed to be in your PATH. ---diffopts Options to pass to the diff command. Defaults to '-u'. +--diffopts Options to pass to the diff command. Defaults to '-u --binary'. -f|force Force download from CPAN of new 02packages.details.txt file (with --crosscheck only). @@ -88,6 +80,10 @@ those in the perl source tree. Must be run from the root of the perl source tree. Module names must match the keys of %Modules in Maintainers.pl. + +The diff(1) command is assumed to be in your PATH and is used to diff files +regardless of whether the --diff option has been chosen to display any file +differences. HERE exit(1); } @@ -101,7 +97,7 @@ sub run { my $mirror_url = "http://www.cpan.org/"; my $use_diff; my $output_file; - my $verbose; + my $verbose = 0; my $force; my $do_crosscheck; @@ -116,7 +112,7 @@ sub run { 'o|output=s' => \$output_file, 'r|reverse' => \$reverse, 'u|upstream=s@' => \@wanted_upstreams, - 'v|verbose' => \$verbose, + 'v|verbose:1' => \$verbose, 'x|crosscheck' => \$do_crosscheck, ) or usage; @@ -125,11 +121,11 @@ sub run { usage("Cannot mix -a with module list") if $scan_all && @ARGV; if ($do_crosscheck) { - usage("can't use -r, -d, --diffopts, -v with --crosscheck") - if ( $reverse || $use_diff || $diff_opts || $verbose ); + usage("can't use -r, -d, --diffopts with --crosscheck") + if ( $reverse || $use_diff || $diff_opts ); } else { - $diff_opts = '-u -b' unless defined $diff_opts; + $diff_opts = '-u --binary' unless defined $diff_opts; usage("can't use -f without --crosscheck") if $force; } @@ -151,7 +147,9 @@ sub run { } 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 ); @@ -165,9 +163,13 @@ sub run { ) or die "ERROR: not a CPAN mirror '$mirror_url'\n"; if ($do_crosscheck) { - do_crosscheck( $outfh, $cache_dir, $mirror_url, $force, \@modules ); + do_crosscheck( + $outfh, $cache_dir, $mirror_url, $verbose, + $force, \@modules, \@wanted_upstreams + ); } else { + $verbose > 2 and $use_diff++; do_compare( \@modules, $outfh, $output_file, $cache_dir, $mirror_url, $verbose, @@ -217,6 +219,7 @@ sub do_compare { } my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE; + my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams; my %seen_dist; for my $module (@$modules) { @@ -237,13 +240,13 @@ sub do_compare { warn "WARNING: duplicate entry for $dist in $module\n"; } - my $upstream = $m->{UPSTREAM} || 'UNKNOWN'; - 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"; print $outfh " upstream is: " - . ( $m->{UPSTREAM} || 'UNKNOWN!' ) . "\n"; + . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n"; my $cpan_dir; eval { @@ -335,8 +338,10 @@ EOF file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse, $diff_opts ); if ( $different && customized( $m, $relative_mapped_file ) ) { - if (! $use_diff ) { - print $outfh " Customized for blead: $relative_mapped_file\n"; + print $outfh " Customized for blead: $relative_mapped_file\n"; + if ( $use_diff && $verbose ) { + $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm; + print $outfh $different; } } elsif ($different) { @@ -395,6 +400,24 @@ EOF print $outfh " Perl only: $_\n" unless $use_diff; } } + if ( $verbose ) { + foreach my $exclude (@$excluded) { + my $seen = 0; + foreach my $cpan_file (@cpan_files) { + # may be a simple string to match exactly, or a pattern + if ( ref $exclude ) { + $seen = 1 if $cpan_file =~ $exclude; + } + else { + $seen = 1 if $cpan_file eq $exclude; + } + last if $seen; + } + if ( not $seen ) { + print $outfh " Unnecessary exclusion: $exclude\n"; + } + } + } } } @@ -419,7 +442,10 @@ sub distro_base { # Maintainers.pl sub do_crosscheck { - my ( $outfh, $cache_dir, $mirror_url, $force, $modules ) = @_; + my ( + $outfh, $cache_dir, $mirror_url, $verbose, + $force, $modules, $wanted_upstreams, + ) = @_; my $file = '02packages.details.txt'; my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 ); @@ -465,10 +491,13 @@ sub do_crosscheck { $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"; + $verbose and warn "Checking $module\n"; + unless ( $m->{CPAN} ) { print $outfh "\nWARNING: $module is not dual-life; skipping\n"; next; @@ -482,6 +511,9 @@ sub do_crosscheck { my $pdist = $m->{DISTRIBUTION}; die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist; + my $upstream = $m->{UPSTREAM} // 'undef'; + next if @$wanted_upstreams and !$wanted_upstream{$upstream}; + my $cdist = $modules{$module}; ( my $short_pdist = $pdist ) =~ s{^.*/}{}; @@ -494,7 +526,7 @@ sub do_crosscheck { if ( keys %$d > 1 ) { print $outfh "\n$module: (found more than one CPAN candidate):\n"; - print $outfh " perl: $pdist\n"; + print $outfh " Perl: $pdist\n"; print $outfh " CPAN: $_\n" for sort keys %$d; next; } @@ -508,7 +540,7 @@ sub do_crosscheck { } # 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 ) = @_; @@ -563,8 +595,9 @@ sub get_map { 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 ) { @@ -625,7 +658,7 @@ sub get_distribution { if ( -f $download_file and !-s $download_file ) { - # wget can leave a zero-length file on failed download + # failed download might leave a zero-length file unlink $download_file; } @@ -642,19 +675,17 @@ sub get_distribution { my $path = catfile( $untar_dir, $filename ); $path =~ s/\.tar\.gz$// + or $path =~ s/\.tgz$// or $path =~ s/\.zip$// or die "ERROR: downloaded file does not have a recognised suffix: $path\n"; # 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; @@ -686,5 +717,70 @@ sub customized { 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();