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