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 = 0;
 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:1'   => \$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 with --crosscheck")
 125           if ( $reverse || $use_diff || $diff_opts );
 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, $verbose,
 168             $force, \@modules,  \@wanted_upstreams
 169         );
 170     }
 171     else {
 172         $verbose > 2 and $use_diff++;
 173         do_compare(
 174             \@modules,  $outfh,      $output_file,
 175             $cache_dir, $mirror_url, $verbose,
 176             $use_diff,  $reverse,    $diff_opts,
 177             \@wanted_upstreams
 178         );
 179     }
 180 }
 181
 182 # construct a CPAN url
 183
 184 sub cpan_url {
 185     my ( $mirror_url, @path ) = @_;
 186     return $mirror_url unless @path;
 187     my $cpan_path = join( "/", map { split "/", $_ } @path );
 188     $cpan_path =~ s{\A/}{};    # remove leading slash since url has one trailing
 189     return $mirror_url . $cpan_path;
 190 }
 191
 192 # construct a CPAN URL for a author/distribution string like:
 193 # BINGOS/Archive-Extract-0.52.tar.gz
 194
 195 sub cpan_url_distribution {
 196     my ( $mirror_url, $distribution ) = @_;
 197     $distribution =~ /^([A-Z])([A-Z])/
 198         or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
 199     my $path = "authors/id/$1/$1$2/$distribution";
 200     return cpan_url( $mirror_url, $path );
 201 }
 202
 203 # compare a list of modules against their CPAN equivalents
 204
 205 sub do_compare {
 206     my (
 207         $modules,    $outfh,   $output_file, $cache_dir,
 208         $mirror_url, $verbose, $use_diff,    $reverse,
 209         $diff_opts,  $wanted_upstreams
 210     ) = @_;
 211
 212     # first, make sure we have a directory where they can all be untarred,
 213     # and if its a permanent directory, clear any previous content
 214     my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
 215     my $src_dir   = catdir( $cache_dir, SRC_DIR );
 216     for my $d ( $src_dir, $untar_dir ) {
 217         next if -d $d;
 218         mkdir $d or die "mkdir $d: $!\n";
 219     }
 220
 221     my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
 222     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
 223
 224     my %seen_dist;
 225     for my $module (@$modules) {
 226         warn "Processing $module ...\n" if defined $output_file;
 227
 228         my $m = $Maintainers::Modules{$module}
 229           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 230
 231         unless ( $m->{CPAN} ) {
 232             print $outfh "WARNING: $module is not dual-life; skipping\n";
 233             next;
 234         }
 235
 236         my $dist = $m->{DISTRIBUTION};
 237         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
 238
 239         if ( $seen_dist{$dist}++ ) {
 240             warn "WARNING: duplicate entry for $dist in $module\n";
 241         }
 242
 243         my $upstream = $m->{UPSTREAM} // 'undef';
 244         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
 245
 246         print $outfh "\n$module - "
 247           . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
 248         print $outfh "  upstream is: "
 249           . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
 250
 251         my $cpan_dir;
 252         eval {
 253             $cpan_dir =
 254               get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
 255                 $dist );
 256         };
 257         if ($@) {
 258             print $outfh "  ", $@;
 259             print $outfh "  (skipping)\n";
 260             next;
 261         }
 262
 263         my @perl_files = Maintainers::get_module_files($module);
 264
 265         my $manifest = catfile( $cpan_dir, 'MANIFEST' );
 266         die "ERROR: no such file: $manifest\n" unless -f $manifest;
 267
 268         my $cpan_files = ExtUtils::Manifest::maniread($manifest);
 269         my @cpan_files = sort keys %$cpan_files;
 270
 271         ( my $main_pm = $module ) =~ s{::}{/}g;
 272         $main_pm .= ".pm";
 273
 274         my ( $excluded, $map, $customized ) =
 275           get_map( $m, $module, \@perl_files );
 276
 277         my %perl_unseen;
 278         @perl_unseen{@perl_files} = ();
 279         my %perl_files = %perl_unseen;
 280
 281         foreach my $cpan_file (@cpan_files) {
 282             my $mapped_file =
 283               cpan_to_perl( $excluded, $map, $customized, $cpan_file );
 284             unless ( defined $mapped_file ) {
 285                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
 286                 next;
 287             }
 288
 289             if ( exists $perl_files{$mapped_file} ) {
 290                 delete $perl_unseen{$mapped_file};
 291             }
 292             else {
 293
 294                 # some CPAN files foo are stored in core as foo.packed,
 295                 # which are then unpacked by 'make test_prep'
 296                 my $packed_file = "$mapped_file.packed";
 297                 if ( exists $perl_files{$packed_file} ) {
 298                     if ( !-f $mapped_file and -f $packed_file ) {
 299                         print $outfh <<EOF;
 300 WARNING: $mapped_file not found, but .packed variant exists.
 301 Perhaps you need to run 'make test_prep'?
 302 EOF
 303                         next;
 304                     }
 305                     delete $perl_unseen{$packed_file};
 306                 }
 307                 else {
 308                     if ( $ignorable{$cpan_file} ) {
 309                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
 310                         next;
 311                     }
 312
 313                     unless ($use_diff) {
 314                         print $outfh "  CPAN only: $cpan_file",
 315                           ( $cpan_file eq $mapped_file )
 316                           ? "\n"
 317                           : " (missing $mapped_file)\n";
 318                     }
 319                     next;
 320                 }
 321             }
 322
 323             my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
 324
 325             # should never happen
 326             die "ERROR: can't find file $abs_cpan_file\n"
 327               unless -f $abs_cpan_file;
 328
 329             # might happen if the FILES entry in Maintainers.pl is wrong
 330             unless ( -f $mapped_file ) {
 331                 print $outfh "WARNING: perl file not found: $mapped_file\n";
 332                 next;
 333             }
 334
 335             my $relative_mapped_file = relatively_mapped($mapped_file);
 336
 337             my $different =
 338               file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
 339                 $diff_opts );
 340             if ( $different && customized( $m, $relative_mapped_file ) ) {
 341                 print $outfh "  Customized for blead: $relative_mapped_file\n";
 342                 if ( $use_diff && $verbose ) {
 343                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
 344                     print $outfh $different;
 345                 }
 346             }
 347             elsif ($different) {
 348                 if ($use_diff) {
 349                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
 350                     print $outfh $different;
 351                 }
 352                 else {
 353                     if ( $cpan_file eq $relative_mapped_file ) {
 354                         print $outfh "  Modified:  $relative_mapped_file\n";
 355                     }
 356                     else {
 357                         print $outfh
 358                           "  Modified:  $cpan_file $relative_mapped_file\n";
 359                     }
 360
 361                     if ( $cpan_file =~ m{\.pm\z} ) {
 362                         my $pv = MM->parse_version($mapped_file)   || 'unknown';
 363                         my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
 364                         if ( $pv ne $cv ) {
 365                             print $outfh
 366 "  Version mismatch in '$cpan_file':\n    $cv (cpan) vs $pv (perl)\n";
 367                         }
 368                     }
 369
 370                 }
 371             }
 372             elsif ( customized( $m, $relative_mapped_file ) ) {
 373                 # Maintainers.pl says we customized it, but it looks the
 374                 # same as CPAN so maybe we lost the customization, which
 375                 # could be bad
 376                 if ( $cpan_file eq $relative_mapped_file ) {
 377                     print $outfh "  Blead customization missing: $cpan_file\n";
 378                 }
 379                 else {
 380                     print $outfh
 381                       "  Blead customization missing: $cpan_file $relative_mapped_file\n";
 382                 }
 383             }
 384             elsif ($verbose) {
 385                 if ( $cpan_file eq $relative_mapped_file ) {
 386                     print $outfh "  Unchanged: $cpan_file\n";
 387                 }
 388                 else {
 389                     print $outfh
 390                       "  Unchanged: $cpan_file $relative_mapped_file\n";
 391                 }
 392             }
 393         }
 394         for ( sort keys %perl_unseen ) {
 395             my $relative_mapped_file = relatively_mapped($_);
 396             if ( customized( $m, $relative_mapped_file ) ) {
 397                 print $outfh "  Customized for blead: $_\n";
 398             }
 399             else {
 400                 print $outfh "  Perl only: $_\n" unless $use_diff;
 401             }
 402         }
 403         if ( $verbose ) {
 404             foreach my $exclude (@$excluded) {
 405                 my $seen = 0;
 406                 foreach my $cpan_file (@cpan_files) {
 407                     # may be a simple string to match exactly, or a pattern
 408                     if ( ref $exclude ) {
 409                         $seen = 1 if $cpan_file =~ $exclude;
 410                     }
 411                     else {
 412                         $seen = 1 if $cpan_file eq $exclude;
 413                     }
 414                     last if $seen;
 415                 }
 416                 if ( not $seen ) {
 417                     print $outfh "  Unnecessary exclusion: $exclude\n";
 418                 }
 419             }
 420         }
 421     }
 422 }
 423
 424 sub relatively_mapped {
 425     my $relative = shift;
 426     $relative =~ s/^(cpan|dist|ext)\/.*?\///;
 427     return $relative;
 428 }
 429
 430 # given FooBar-1.23_45.tar.gz, return FooBar
 431
 432 sub distro_base {
 433     my $d = shift;
 434     $d =~ s/\.tar\.gz$//;
 435     $d =~ s/\.gip$//;
 436     $d =~ s/[\d\-_\.]+$//;
 437     return $d;
 438 }
 439
 440 # process --crosscheck action:
 441 # ie list all distributions whose CPAN versions differ from that listed in
 442 # Maintainers.pl
 443
 444 sub do_crosscheck {
 445     my (
 446         $outfh, $cache_dir, $mirror_url, $verbose,
 447         $force, $modules,   $wanted_upstreams,
 448     ) = @_;
 449
 450     my $file         = '02packages.details.txt';
 451     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
 452     my $path         = catfile( $download_dir, $file );
 453     my $gzfile       = "$path.gz";
 454
 455     # grab 02packages.details.txt
 456
 457     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
 458
 459     if ( !-f $gzfile or $force ) {
 460         unlink $gzfile;
 461         my_getstore( $url, $gzfile );
 462     }
 463     unlink $path;
 464     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
 465       or die
 466       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
 467
 468     # suck in the data from it
 469
 470     open my $fh, '<', $path
 471       or die "ERROR: open: $file: $!\n";
 472
 473     my %distros;
 474     my %modules;
 475
 476     while (<$fh>) {
 477         next if 1 .. /^$/;
 478         chomp;
 479         my @f = split ' ', $_;
 480         if ( @f != 3 ) {
 481             warn
 482               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
 483             next;
 484         }
 485         my $distro = $f[2];
 486         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
 487         $modules{ $f[0] } = $distro;
 488
 489         ( my $short_distro = $distro ) =~ s{^.*/}{};
 490
 491         $distros{ distro_base($short_distro) }{$distro} = 1;
 492     }
 493
 494     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
 495     for my $module (@$modules) {
 496         my $m = $Maintainers::Modules{$module}
 497           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 498
 499         $verbose and warn "Checking $module\n";
 500
 501         unless ( $m->{CPAN} ) {
 502             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
 503             next;
 504         }
 505
 506         # given an entry like
 507         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
 508         # first compare the module name against Foo::Bar, and failing that,
 509         # against foo-bar
 510
 511         my $pdist = $m->{DISTRIBUTION};
 512         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
 513
 514         my $upstream = $m->{UPSTREAM} // 'undef';
 515         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
 516
 517         my $cdist = $modules{$module};
 518         ( my $short_pdist = $pdist ) =~ s{^.*/}{};
 519
 520         unless ( defined $cdist ) {
 521             my $d = $distros{ distro_base($short_pdist) };
 522             unless ( defined $d ) {
 523                 print $outfh "\n$module: Can't determine current CPAN entry\n";
 524                 next;
 525             }
 526             if ( keys %$d > 1 ) {
 527                 print $outfh
 528                   "\n$module: (found more than one CPAN candidate):\n";
 529                 print $outfh "    perl: $pdist\n";
 530                 print $outfh "    CPAN: $_\n" for sort keys %$d;
 531                 next;
 532             }
 533             $cdist = ( keys %$d )[0];
 534         }
 535
 536         if ( $cdist ne $pdist ) {
 537             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
 538         }
 539     }
 540 }
 541
 542 # get the EXCLUDED and MAP entries for this module, or
 543 # make up defaults if they don't exist
 544
 545 sub get_map {
 546     my ( $m, $module_name, $perl_files ) = @_;
 547
 548     my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
 549
 550     $excluded   ||= [];
 551     $customized ||= [];
 552
 553     return $excluded, $map, $customized if $map;
 554
 555     # all files under ext/foo-bar (plus maybe some under t/lib)???
 556
 557     my $ext;
 558     for (@$perl_files) {
 559         if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
 560             if ( defined $ext and $ext ne $1 ) {
 561
 562                 # more than one ext/$ext/
 563                 undef $ext;
 564                 last;
 565             }
 566             $ext = $1;
 567         }
 568         elsif (m{^t/lib/}) {
 569             next;
 570         }
 571         else {
 572             undef $ext;
 573             last;
 574         }
 575     }
 576
 577     if ( defined $ext ) {
 578         $map = { '' => $ext },;
 579     }
 580     else {
 581         ( my $base = $module_name ) =~ s{::}{/}g;
 582         $base = "lib/$base";
 583         $map  = {
 584             'lib/' => 'lib/',
 585             ''     => "$base/",
 586         };
 587     }
 588     return $excluded, $map, $customized;
 589 }
 590
 591 # Given an exclude list and a mapping hash, convert a CPAN filename
 592 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
 593 # Returns an empty list for an excluded file
 594
 595 sub cpan_to_perl {
 596     my ( $excluded, $map, $customized, $cpan_file ) = @_;
 597
 598     my %customized = map { ( $_ => 1 ) } @$customized;
 599     for my $exclude (@$excluded) {
 600         next if $customized{$exclude};
 601
 602         # may be a simple string to match exactly, or a pattern
 603         if ( ref $exclude ) {
 604             return if $cpan_file =~ $exclude;
 605         }
 606         else {
 607             return if $cpan_file eq $exclude;
 608         }
 609     }
 610
 611     my $perl_file = $cpan_file;
 612
 613     # try longest prefix first, then alphabetically on tie-break
 614     for
 615       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
 616     {
 617         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
 618     }
 619     return $perl_file;
 620 }
 621
 622 # fetch a file from a URL and store it in a file given by a filename
 623
 624 sub my_getstore {
 625     my ( $url, $file ) = @_;
 626     File::Path::mkpath( File::Basename::dirname($file) );
 627     if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
 628         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
 629         File::Copy::copy( $local_path, $file );
 630     } else {
 631         my $http = HTTP::Tiny->new;
 632         my $response = $http->mirror($url, $file);
 633         return $response->{success};
 634     }
 635 }
 636
 637 # download and unpack a distribution
 638 # Returns the full pathname of the extracted directory
 639 # (eg '/tmp/XYZ/Foo_bar-1.23')
 640
 641 # cache_dir:  where to download the .tar.gz file to
 642 # mirror_url: CPAN mirror to download from
 643 # untar_dir:  where to untar or unzup the file
 644 # module:     name of module
 645 # dist:       name of the distribution
 646
 647 sub get_distribution {
 648     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
 649
 650     $dist =~ m{.+/([^/]+)$}
 651       or die
 652       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
 653     my $filename = $1;
 654
 655     my $download_file = catfile( $src_dir, $filename );
 656
 657     # download distribution
 658
 659     if ( -f $download_file and !-s $download_file ) {
 660
 661         # failed download might leave a zero-length file
 662         unlink $download_file;
 663     }
 664
 665     unless ( -f $download_file ) {
 666
 667         # not cached
 668         my $url = cpan_url_distribution( $mirror_url, $dist );
 669         my_getstore( $url, $download_file )
 670           or die "ERROR: Could not fetch '$url'\n";
 671     }
 672
 673     # get the expected name of the extracted distribution dir
 674
 675     my $path = catfile( $untar_dir, $filename );
 676
 677     $path =~ s/\.tar\.gz$//
 678       or $path =~ s/\.tgz$//
 679       or $path =~ s/\.zip$//
 680       or die
 681       "ERROR: downloaded file does not have a recognised suffix: $path\n";
 682
 683     # extract it unless we already have it cached or tarball is newer
 684     if ( !-d $path || ( -M $download_file < -M $path ) ) {
 685         $path = extract( $download_file, $untar_dir )
 686           or die
 687           "ERROR: failed to extract distribution '$download_file to temp. dir: "
 688           . $! . "\n";
 689     }
 690
 691     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
 692
 693     return $path;
 694 }
 695
 696 # produce the diff of a single file
 697 sub file_diff {
 698     my $outfh     = shift;
 699     my $cpan_file = shift;
 700     my $perl_file = shift;
 701     my $reverse   = shift;
 702     my $diff_opts = shift;
 703
 704     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
 705     if ($reverse) {
 706         push @cmd, $perl_file, $cpan_file;
 707     }
 708     else {
 709         push @cmd, $cpan_file, $perl_file;
 710     }
 711     return `@cmd`;
 712
 713 }
 714
 715 sub customized {
 716     my ( $module_data, $file ) = @_;
 717     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
 718 }
 719
 720 sub extract {
 721   my ($archive,$to) = @_;
 722   my $cwd = cwd();
 723   chdir $to or die "$!\n";
 724   my @files;
 725   EXTRACT: {
 726     local $Archive::Tar::CHOWN = 0;
 727     my $next;
 728     unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
 729        $! = $Archive::Tar::error;
 730        last EXTRACT;
 731     }
 732     while ( my $file = $next->() ) {
 733       push @files, $file->full_path;
 734       unless ( $file->extract ) {
 735         $! = $Archive::Tar::error;
 736         last EXTRACT;
 737       }
 738     }
 739   }
 740   my $path = __get_extract_dir( \@files );
 741   chdir $cwd or die "$!\n";
 742   return $path;
 743 }
 744
 745 sub __get_extract_dir {
 746     my $files   = shift || [];
 747
 748     return unless scalar @$files;
 749
 750     my($dir1, $dir2);
 751     for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
 752         my($dir,$pos) = @$aref;
 753
 754         ### add a catdir(), so that any trailing slashes get
 755         ### take care of (removed)
 756         ### also, a catdir() normalises './dir/foo' to 'dir/foo';
 757         ### which was the problem in bug #23999
 758         my $res = -d $files->[$pos]
 759                     ? File::Spec->catdir( $files->[$pos], '' )
 760                     : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
 761
 762         $$dir = $res;
 763     }
 764
 765     ### if the first and last dir don't match, make sure the
 766     ### dirname is not set wrongly
 767     my $dir;
 768
 769     ### dirs are the same, so we know for sure what the extract dir is
 770     if( $dir1 eq $dir2 ) {
 771         $dir = $dir1;
 772
 773     ### dirs are different.. do they share the base dir?
 774     ### if so, use that, if not, fall back to '.'
 775     } else {
 776         my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
 777         my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
 778
 779         $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
 780     }
 781
 782     return File::Spec->rel2abs( $dir );
 783 }
 784
 785 run();
 786