Porting/core-cpan-diff

   1 #!/usr/bin/env perl
   2
   3 # core-cpan-diff: Compare CPAN modules with their equivalent in core
   4
   5 # Originally based on App::DualLivedDiff by Steffen Mueller.
   6
   7 use strict;
   8 use warnings;
   9
  10 use 5.010;
  11
  12 use Getopt::Long;
  13 use File::Basename ();
  14 use File::Copy     ();
  15 use File::Temp     ();
  16 use File::Path     ();
  17 use File::Spec;
  18 use File::Spec::Functions;
  19 use IO::Uncompress::Gunzip ();
  20 use File::Compare          ();
  21 use ExtUtils::Manifest;
  22 use ExtUtils::MakeMaker ();
  23 use HTTP::Tiny;
  24
  25 BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
  26 use lib 'Porting';
  27 use Maintainers ();
  28
  29 use Archive::Tar;
  30 use Cwd qw[cwd chdir];
  31 use IPC::Open3;
  32 use IO::Select;
  33 local $Archive::Tar::WARN=0;
  34
  35 # where, under the cache dir, to download tarballs to
  36 use constant SRC_DIR => 'tarballs';
  37
  38 # where, under the cache dir, to untar stuff to
  39 use constant UNTAR_DIR => 'untarred';
  40
  41 use constant DIFF_CMD => 'diff';
  42
  43 sub usage {
  44     print STDERR "\n@_\n\n" if @_;
  45     print STDERR <<HERE;
  46 Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
  47
  48 -a/--all      Scan all dual-life modules.
  49
  50 -c/--cachedir Where to save downloaded CPAN tarball files
  51               (defaults to /tmp/something/ with deletion after each run).
  52
  53 -d/--diff     Display file differences using diff(1), rather than just
  54               listing which files have changed.
  55
  56 --diffopts    Options to pass to the diff command. Defaults to '-u'.
  57
  58 -f|force      Force download from CPAN of new 02packages.details.txt file
  59               (with --crosscheck only).
  60
  61 -m|mirror     Preferred CPAN mirror URI (http:// or file:///)
  62               (Local mirror must be a complete mirror, not minicpan)
  63
  64 -o/--output   File name to write output to (defaults to STDOUT).
  65
  66 -r/--reverse  Reverses the diff (perl to CPAN).
  67
  68 -u/--upstream only print modules with the given upstream (defaults to all)
  69
  70 -v/--verbose  List the fate of *all* files in the tarball, not just those
  71               that differ or are missing.
  72
  73 -x|crosscheck List the distributions whose current CPAN version differs from
  74               that in blead (i.e. the DISTRIBUTION field in Maintainers.pl).
  75
  76 By default (i.e. without the --crosscheck option),  for each listed module
  77 (or with -a, all CPAN modules listed in Maintainers.pl), grab the tarball
  78 from CPAN associated with that module, and compare the files in it with
  79 those in the perl source tree.
  80
  81 Must be run from the root of the perl source tree.
  82 Module names must match the keys of %Modules in Maintainers.pl.
  83
  84 The diff(1) command is assumed to be in your PATH and is used to diff files
  85 regardless of whether the --diff option has been chosen to display any file
  86 differences.
  87 HERE
  88     exit(1);
  89 }
  90
  91 sub run {
  92     my $scan_all;
  93     my $diff_opts;
  94     my $reverse = 0;
  95     my @wanted_upstreams;
  96     my $cache_dir;
  97     my $mirror_url = "http://www.cpan.org/";
  98     my $use_diff;
  99     my $output_file;
 100     my $verbose;
 101     my $force;
 102     my $do_crosscheck;
 103
 104     GetOptions(
 105         'a|all'         => \$scan_all,
 106         'c|cachedir=s'  => \$cache_dir,
 107         'd|diff'        => \$use_diff,
 108         'diffopts:s'    => \$diff_opts,
 109         'f|force'       => \$force,
 110         'h|help'        => \&usage,
 111         'm|mirror=s'    => \$mirror_url,
 112         'o|output=s'    => \$output_file,
 113         'r|reverse'     => \$reverse,
 114         'u|upstream=s@' => \@wanted_upstreams,
 115         'v|verbose'     => \$verbose,
 116         'x|crosscheck'  => \$do_crosscheck,
 117     ) or usage;
 118
 119     my @modules;
 120
 121     usage("Cannot mix -a with module list") if $scan_all && @ARGV;
 122
 123     if ($do_crosscheck) {
 124         usage("can't use -r, -d, --diffopts, -v with --crosscheck")
 125           if ( $reverse || $use_diff || $diff_opts || $verbose );
 126     }
 127     else {
 128         $diff_opts = '-u -b' unless defined $diff_opts;
 129         usage("can't use -f without --crosscheck") if $force;
 130     }
 131
 132     @modules =
 133       $scan_all
 134       ? grep $Maintainers::Modules{$_}{CPAN},
 135       ( sort { lc $a cmp lc $b } keys %Maintainers::Modules )
 136       : @ARGV;
 137     usage("No modules specified") unless @modules;
 138
 139     my $outfh;
 140     if ( defined $output_file ) {
 141         open $outfh, '>', $output_file
 142           or die "ERROR: could not open file '$output_file' for writing: $!\n";
 143     }
 144     else {
 145         open $outfh, ">&STDOUT"
 146           or die "ERROR: can't dup STDOUT: $!\n";
 147     }
 148
 149     if ( defined $cache_dir ) {
 150         die "ERROR: not a directory: '$cache_dir'\n"
 151             if !-d $cache_dir && -e $cache_dir;
 152         File::Path::mkpath($cache_dir);
 153     }
 154     else {
 155         $cache_dir = File::Temp::tempdir( CLEANUP => 1 );
 156     }
 157
 158     $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/";
 159     my $test_file = "modules/03modlist.data.gz";
 160     my_getstore(
 161         cpan_url( $mirror_url, $test_file ),
 162         catfile( $cache_dir, $test_file )
 163     ) or die "ERROR: not a CPAN mirror '$mirror_url'\n";
 164
 165     if ($do_crosscheck) {
 166         do_crosscheck(
 167             $outfh, $cache_dir, $mirror_url,
 168             $force, \@modules,  \@wanted_upstreams
 169         );
 170     }
 171     else {
 172         do_compare(
 173             \@modules,  $outfh,      $output_file,
 174             $cache_dir, $mirror_url, $verbose,
 175             $use_diff,  $reverse,    $diff_opts,
 176             \@wanted_upstreams
 177         );
 178     }
 179 }
 180
 181 # construct a CPAN url
 182
 183 sub cpan_url {
 184     my ( $mirror_url, @path ) = @_;
 185     return $mirror_url unless @path;
 186     my $cpan_path = join( "/", map { split "/", $_ } @path );
 187     $cpan_path =~ s{\A/}{};    # remove leading slash since url has one trailing
 188     return $mirror_url . $cpan_path;
 189 }
 190
 191 # construct a CPAN URL for a author/distribution string like:
 192 # BINGOS/Archive-Extract-0.52.tar.gz
 193
 194 sub cpan_url_distribution {
 195     my ( $mirror_url, $distribution ) = @_;
 196     $distribution =~ /^([A-Z])([A-Z])/
 197         or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
 198     my $path = "authors/id/$1/$1$2/$distribution";
 199     return cpan_url( $mirror_url, $path );
 200 }
 201
 202 # compare a list of modules against their CPAN equivalents
 203
 204 sub do_compare {
 205     my (
 206         $modules,    $outfh,   $output_file, $cache_dir,
 207         $mirror_url, $verbose, $use_diff,    $reverse,
 208         $diff_opts,  $wanted_upstreams
 209     ) = @_;
 210
 211     # first, make sure we have a directory where they can all be untarred,
 212     # and if its a permanent directory, clear any previous content
 213     my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
 214     my $src_dir   = catdir( $cache_dir, SRC_DIR );
 215     for my $d ( $src_dir, $untar_dir ) {
 216         next if -d $d;
 217         mkdir $d or die "mkdir $d: $!\n";
 218     }
 219
 220     my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
 221     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
 222
 223     my %seen_dist;
 224     for my $module (@$modules) {
 225         warn "Processing $module ...\n" if defined $output_file;
 226
 227         my $m = $Maintainers::Modules{$module}
 228           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 229
 230         unless ( $m->{CPAN} ) {
 231             print $outfh "WARNING: $module is not dual-life; skipping\n";
 232             next;
 233         }
 234
 235         my $dist = $m->{DISTRIBUTION};
 236         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
 237
 238         if ( $seen_dist{$dist}++ ) {
 239             warn "WARNING: duplicate entry for $dist in $module\n";
 240         }
 241
 242         my $upstream = $m->{UPSTREAM} // 'undef';
 243         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
 244
 245         print $outfh "\n$module - "
 246           . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
 247         print $outfh "  upstream is: "
 248           . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
 249
 250         my $cpan_dir;
 251         eval {
 252             $cpan_dir =
 253               get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
 254                 $dist );
 255         };
 256         if ($@) {
 257             print $outfh "  ", $@;
 258             print $outfh "  (skipping)\n";
 259             next;
 260         }
 261
 262         my @perl_files = Maintainers::get_module_files($module);
 263
 264         my $manifest = catfile( $cpan_dir, 'MANIFEST' );
 265         die "ERROR: no such file: $manifest\n" unless -f $manifest;
 266
 267         my $cpan_files = ExtUtils::Manifest::maniread($manifest);
 268         my @cpan_files = sort keys %$cpan_files;
 269
 270         ( my $main_pm = $module ) =~ s{::}{/}g;
 271         $main_pm .= ".pm";
 272
 273         my ( $excluded, $map, $customized ) =
 274           get_map( $m, $module, \@perl_files );
 275
 276         my %perl_unseen;
 277         @perl_unseen{@perl_files} = ();
 278         my %perl_files = %perl_unseen;
 279
 280         foreach my $cpan_file (@cpan_files) {
 281             my $mapped_file =
 282               cpan_to_perl( $excluded, $map, $customized, $cpan_file );
 283             unless ( defined $mapped_file ) {
 284                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
 285                 next;
 286             }
 287
 288             if ( exists $perl_files{$mapped_file} ) {
 289                 delete $perl_unseen{$mapped_file};
 290             }
 291             else {
 292
 293                 # some CPAN files foo are stored in core as foo.packed,
 294                 # which are then unpacked by 'make test_prep'
 295                 my $packed_file = "$mapped_file.packed";
 296                 if ( exists $perl_files{$packed_file} ) {
 297                     if ( !-f $mapped_file and -f $packed_file ) {
 298                         print $outfh <<EOF;
 299 WARNING: $mapped_file not found, but .packed variant exists.
 300 Perhaps you need to run 'make test_prep'?
 301 EOF
 302                         next;
 303                     }
 304                     delete $perl_unseen{$packed_file};
 305                 }
 306                 else {
 307                     if ( $ignorable{$cpan_file} ) {
 308                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
 309                         next;
 310                     }
 311
 312                     unless ($use_diff) {
 313                         print $outfh "  CPAN only: $cpan_file",
 314                           ( $cpan_file eq $mapped_file )
 315                           ? "\n"
 316                           : " (missing $mapped_file)\n";
 317                     }
 318                     next;
 319                 }
 320             }
 321
 322             my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
 323
 324             # should never happen
 325             die "ERROR: can't find file $abs_cpan_file\n"
 326               unless -f $abs_cpan_file;
 327
 328             # might happen if the FILES entry in Maintainers.pl is wrong
 329             unless ( -f $mapped_file ) {
 330                 print $outfh "WARNING: perl file not found: $mapped_file\n";
 331                 next;
 332             }
 333
 334             my $relative_mapped_file = relatively_mapped($mapped_file);
 335
 336             my $different =
 337               file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
 338                 $diff_opts );
 339             if ( $different && customized( $m, $relative_mapped_file ) ) {
 340                 if (! $use_diff ) {
 341                     print $outfh "  Customized for blead: $relative_mapped_file\n";
 342                 }
 343             }
 344             elsif ($different) {
 345                 if ($use_diff) {
 346                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
 347                     print $outfh $different;
 348                 }
 349                 else {
 350                     if ( $cpan_file eq $relative_mapped_file ) {
 351                         print $outfh "  Modified:  $relative_mapped_file\n";
 352                     }
 353                     else {
 354                         print $outfh
 355                           "  Modified:  $cpan_file $relative_mapped_file\n";
 356                     }
 357
 358                     if ( $cpan_file =~ m{\.pm\z} ) {
 359                         my $pv = MM->parse_version($mapped_file)   || 'unknown';
 360                         my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
 361                         if ( $pv ne $cv ) {
 362                             print $outfh
 363 "  Version mismatch in '$cpan_file':\n    $cv (cpan) vs $pv (perl)\n";
 364                         }
 365                     }
 366
 367                 }
 368             }
 369             elsif ( customized( $m, $relative_mapped_file ) ) {
 370                 # Maintainers.pl says we customized it, but it looks the
 371                 # same as CPAN so maybe we lost the customization, which
 372                 # could be bad
 373                 if ( $cpan_file eq $relative_mapped_file ) {
 374                     print $outfh "  Blead customization missing: $cpan_file\n";
 375                 }
 376                 else {
 377                     print $outfh
 378                       "  Blead customization missing: $cpan_file $relative_mapped_file\n";
 379                 }
 380             }
 381             elsif ($verbose) {
 382                 if ( $cpan_file eq $relative_mapped_file ) {
 383                     print $outfh "  Unchanged: $cpan_file\n";
 384                 }
 385                 else {
 386                     print $outfh
 387                       "  Unchanged: $cpan_file $relative_mapped_file\n";
 388                 }
 389             }
 390         }
 391         for ( sort keys %perl_unseen ) {
 392             my $relative_mapped_file = relatively_mapped($_);
 393             if ( customized( $m, $relative_mapped_file ) ) {
 394                 print $outfh "  Customized for blead: $_\n";
 395             }
 396             else {
 397                 print $outfh "  Perl only: $_\n" unless $use_diff;
 398             }
 399         }
 400         if ( $verbose ) {
 401             foreach my $exclude (@$excluded) {
 402                 my $seen = 0;
 403                 foreach my $cpan_file (@cpan_files) {
 404                     # may be a simple string to match exactly, or a pattern
 405                     if ( ref $exclude ) {
 406                         $seen = 1 if $cpan_file =~ $exclude;
 407                     }
 408                     else {
 409                         $seen = 1 if $cpan_file eq $exclude;
 410                     }
 411                     last if $seen;
 412                 }
 413                 if ( not $seen ) {
 414                     print $outfh "  Unnecessary exclusion: $exclude\n";
 415                 }
 416             }
 417         }
 418     }
 419 }
 420
 421 sub relatively_mapped {
 422     my $relative = shift;
 423     $relative =~ s/^(cpan|dist|ext)\/.*?\///;
 424     return $relative;
 425 }
 426
 427 # given FooBar-1.23_45.tar.gz, return FooBar
 428
 429 sub distro_base {
 430     my $d = shift;
 431     $d =~ s/\.tar\.gz$//;
 432     $d =~ s/\.gip$//;
 433     $d =~ s/[\d\-_\.]+$//;
 434     return $d;
 435 }
 436
 437 # process --crosscheck action:
 438 # ie list all distributions whose CPAN versions differ from that listed in
 439 # Maintainers.pl
 440
 441 sub do_crosscheck {
 442     my (
 443         $outfh, $cache_dir, $mirror_url,
 444         $force, $modules,   $wanted_upstreams,
 445     ) = @_;
 446
 447     my $file         = '02packages.details.txt';
 448     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
 449     my $path         = catfile( $download_dir, $file );
 450     my $gzfile       = "$path.gz";
 451
 452     # grab 02packages.details.txt
 453
 454     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
 455
 456     if ( !-f $gzfile or $force ) {
 457         unlink $gzfile;
 458         my_getstore( $url, $gzfile );
 459     }
 460     unlink $path;
 461     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
 462       or die
 463       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
 464
 465     # suck in the data from it
 466
 467     open my $fh, '<', $path
 468       or die "ERROR: open: $file: $!\n";
 469
 470     my %distros;
 471     my %modules;
 472
 473     while (<$fh>) {
 474         next if 1 .. /^$/;
 475         chomp;
 476         my @f = split ' ', $_;
 477         if ( @f != 3 ) {
 478             warn
 479               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
 480             next;
 481         }
 482         my $distro = $f[2];
 483         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
 484         $modules{ $f[0] } = $distro;
 485
 486         ( my $short_distro = $distro ) =~ s{^.*/}{};
 487
 488         $distros{ distro_base($short_distro) }{$distro} = 1;
 489     }
 490
 491     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
 492     for my $module (@$modules) {
 493         my $m = $Maintainers::Modules{$module}
 494           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 495
 496         unless ( $m->{CPAN} ) {
 497             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
 498             next;
 499         }
 500
 501         # given an entry like
 502         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
 503         # first compare the module name against Foo::Bar, and failing that,
 504         # against foo-bar
 505
 506         my $pdist = $m->{DISTRIBUTION};
 507         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
 508
 509         my $upstream = $m->{UPSTREAM} // 'undef';
 510         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
 511
 512         my $cdist = $modules{$module};
 513         ( my $short_pdist = $pdist ) =~ s{^.*/}{};
 514
 515         unless ( defined $cdist ) {
 516             my $d = $distros{ distro_base($short_pdist) };
 517             unless ( defined $d ) {
 518                 print $outfh "\n$module: Can't determine current CPAN entry\n";
 519                 next;
 520             }
 521             if ( keys %$d > 1 ) {
 522                 print $outfh
 523                   "\n$module: (found more than one CPAN candidate):\n";
 524                 print $outfh "    perl: $pdist\n";
 525                 print $outfh "    CPAN: $_\n" for sort keys %$d;
 526                 next;
 527             }
 528             $cdist = ( keys %$d )[0];
 529         }
 530
 531         if ( $cdist ne $pdist ) {
 532             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
 533         }
 534     }
 535 }
 536
 537 # get the EXCLUDED and MAP entries for this module, or
 538 # make up defaults if they don't exist
 539
 540 sub get_map {
 541     my ( $m, $module_name, $perl_files ) = @_;
 542
 543     my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
 544
 545     $excluded   ||= [];
 546     $customized ||= [];
 547
 548     return $excluded, $map, $customized if $map;
 549
 550     # all files under ext/foo-bar (plus maybe some under t/lib)???
 551
 552     my $ext;
 553     for (@$perl_files) {
 554         if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
 555             if ( defined $ext and $ext ne $1 ) {
 556
 557                 # more than one ext/$ext/
 558                 undef $ext;
 559                 last;
 560             }
 561             $ext = $1;
 562         }
 563         elsif (m{^t/lib/}) {
 564             next;
 565         }
 566         else {
 567             undef $ext;
 568             last;
 569         }
 570     }
 571
 572     if ( defined $ext ) {
 573         $map = { '' => $ext },;
 574     }
 575     else {
 576         ( my $base = $module_name ) =~ s{::}{/}g;
 577         $base = "lib/$base";
 578         $map  = {
 579             'lib/' => 'lib/',
 580             ''     => "$base/",
 581         };
 582     }
 583     return $excluded, $map, $customized;
 584 }
 585
 586 # Given an exclude list and a mapping hash, convert a CPAN filename
 587 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
 588 # Returns an empty list for an excluded file
 589
 590 sub cpan_to_perl {
 591     my ( $excluded, $map, $customized, $cpan_file ) = @_;
 592
 593     my %customized = map { ( $_ => 1 ) } @$customized;
 594     for my $exclude (@$excluded) {
 595         next if $customized{$exclude};
 596
 597         # may be a simple string to match exactly, or a pattern
 598         if ( ref $exclude ) {
 599             return if $cpan_file =~ $exclude;
 600         }
 601         else {
 602             return if $cpan_file eq $exclude;
 603         }
 604     }
 605
 606     my $perl_file = $cpan_file;
 607
 608     # try longest prefix first, then alphabetically on tie-break
 609     for
 610       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
 611     {
 612         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
 613     }
 614     return $perl_file;
 615 }
 616
 617 # fetch a file from a URL and store it in a file given by a filename
 618
 619 sub my_getstore {
 620     my ( $url, $file ) = @_;
 621     File::Path::mkpath( File::Basename::dirname($file) );
 622     if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
 623         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
 624         File::Copy::copy( $local_path, $file );
 625     } else {
 626         my $http = HTTP::Tiny->new;
 627         my $response = $http->mirror($url, $file);
 628         return $response->{success};
 629     }
 630 }
 631
 632 # download and unpack a distribution
 633 # Returns the full pathname of the extracted directory
 634 # (eg '/tmp/XYZ/Foo_bar-1.23')
 635
 636 # cache_dir:  where to download the .tar.gz file to
 637 # mirror_url: CPAN mirror to download from
 638 # untar_dir:  where to untar or unzup the file
 639 # module:     name of module
 640 # dist:       name of the distribution
 641
 642 sub get_distribution {
 643     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
 644
 645     $dist =~ m{.+/([^/]+)$}
 646       or die
 647       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
 648     my $filename = $1;
 649
 650     my $download_file = catfile( $src_dir, $filename );
 651
 652     # download distribution
 653
 654     if ( -f $download_file and !-s $download_file ) {
 655
 656         # failed download might leave a zero-length file
 657         unlink $download_file;
 658     }
 659
 660     unless ( -f $download_file ) {
 661
 662         # not cached
 663         my $url = cpan_url_distribution( $mirror_url, $dist );
 664         my_getstore( $url, $download_file )
 665           or die "ERROR: Could not fetch '$url'\n";
 666     }
 667
 668     # get the expected name of the extracted distribution dir
 669
 670     my $path = catfile( $untar_dir, $filename );
 671
 672     $path =~ s/\.tar\.gz$//
 673       or $path =~ s/\.tgz$//
 674       or $path =~ s/\.zip$//
 675       or die
 676       "ERROR: downloaded file does not have a recognised suffix: $path\n";
 677
 678     # extract it unless we already have it cached or tarball is newer
 679     if ( !-d $path || ( -M $download_file < -M $path ) ) {
 680         $path = extract( $download_file, $untar_dir )
 681           or die
 682           "ERROR: failed to extract distribution '$download_file to temp. dir: "
 683           . $! . "\n";
 684     }
 685
 686     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
 687
 688     return $path;
 689 }
 690
 691 # produce the diff of a single file
 692 sub file_diff {
 693     my $outfh     = shift;
 694     my $cpan_file = shift;
 695     my $perl_file = shift;
 696     my $reverse   = shift;
 697     my $diff_opts = shift;
 698
 699     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
 700     if ($reverse) {
 701         push @cmd, $perl_file, $cpan_file;
 702     }
 703     else {
 704         push @cmd, $cpan_file, $perl_file;
 705     }
 706     return `@cmd`;
 707
 708 }
 709
 710 sub customized {
 711     my ( $module_data, $file ) = @_;
 712     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
 713 }
 714
 715 sub extract {
 716   my ($archive,$to) = @_;
 717   my $cwd = cwd();
 718   chdir $to or die "$!\n";
 719   my @files;
 720   EXTRACT: {
 721     local $Archive::Tar::CHOWN = 0;
 722     my $next;
 723     unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
 724        $! = $Archive::Tar::error;
 725        last EXTRACT;
 726     }
 727     while ( my $file = $next->() ) {
 728       push @files, $file->full_path;
 729       unless ( $file->extract ) {
 730         $! = $Archive::Tar::error;
 731         last EXTRACT;
 732       }
 733     }
 734   }
 735   my $path = __get_extract_dir( \@files );
 736   chdir $cwd or die "$!\n";
 737   return $path;
 738 }
 739
 740 sub __get_extract_dir {
 741     my $files   = shift || [];
 742
 743     return unless scalar @$files;
 744
 745     my($dir1, $dir2);
 746     for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
 747         my($dir,$pos) = @$aref;
 748
 749         ### add a catdir(), so that any trailing slashes get
 750         ### take care of (removed)
 751         ### also, a catdir() normalises './dir/foo' to 'dir/foo';
 752         ### which was the problem in bug #23999
 753         my $res = -d $files->[$pos]
 754                     ? File::Spec->catdir( $files->[$pos], '' )
 755                     : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
 756
 757         $$dir = $res;
 758     }
 759
 760     ### if the first and last dir don't match, make sure the
 761     ### dirname is not set wrongly
 762     my $dir;
 763
 764     ### dirs are the same, so we know for sure what the extract dir is
 765     if( $dir1 eq $dir2 ) {
 766         $dir = $dir1;
 767
 768     ### dirs are different.. do they share the base dir?
 769     ### if so, use that, if not, fall back to '.'
 770     } else {
 771         my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
 772         my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
 773
 774         $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
 775     }
 776
 777     return File::Spec->rel2abs( $dir );
 778 }
 779
 780 run();
 781