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