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     }
 401 }
 402
 403 sub relatively_mapped {
 404     my $relative = shift;
 405     $relative =~ s/^(cpan|dist|ext)\/.*?\///;
 406     return $relative;
 407 }
 408
 409 # given FooBar-1.23_45.tar.gz, return FooBar
 410
 411 sub distro_base {
 412     my $d = shift;
 413     $d =~ s/\.tar\.gz$//;
 414     $d =~ s/\.gip$//;
 415     $d =~ s/[\d\-_\.]+$//;
 416     return $d;
 417 }
 418
 419 # process --crosscheck action:
 420 # ie list all distributions whose CPAN versions differ from that listed in
 421 # Maintainers.pl
 422
 423 sub do_crosscheck {
 424     my (
 425         $outfh, $cache_dir, $mirror_url,
 426         $force, $modules,   $wanted_upstreams,
 427     ) = @_;
 428
 429     my $file         = '02packages.details.txt';
 430     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
 431     my $path         = catfile( $download_dir, $file );
 432     my $gzfile       = "$path.gz";
 433
 434     # grab 02packages.details.txt
 435
 436     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
 437
 438     if ( !-f $gzfile or $force ) {
 439         unlink $gzfile;
 440         my_getstore( $url, $gzfile );
 441     }
 442     unlink $path;
 443     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
 444       or die
 445       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
 446
 447     # suck in the data from it
 448
 449     open my $fh, '<', $path
 450       or die "ERROR: open: $file: $!\n";
 451
 452     my %distros;
 453     my %modules;
 454
 455     while (<$fh>) {
 456         next if 1 .. /^$/;
 457         chomp;
 458         my @f = split ' ', $_;
 459         if ( @f != 3 ) {
 460             warn
 461               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
 462             next;
 463         }
 464         my $distro = $f[2];
 465         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
 466         $modules{ $f[0] } = $distro;
 467
 468         ( my $short_distro = $distro ) =~ s{^.*/}{};
 469
 470         $distros{ distro_base($short_distro) }{$distro} = 1;
 471     }
 472
 473     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
 474     for my $module (@$modules) {
 475         my $m = $Maintainers::Modules{$module}
 476           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 477
 478         unless ( $m->{CPAN} ) {
 479             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
 480             next;
 481         }
 482
 483         # given an entry like
 484         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
 485         # first compare the module name against Foo::Bar, and failing that,
 486         # against foo-bar
 487
 488         my $pdist = $m->{DISTRIBUTION};
 489         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
 490
 491         my $upstream = $m->{UPSTREAM} // 'undef';
 492         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
 493
 494         my $cdist = $modules{$module};
 495         ( my $short_pdist = $pdist ) =~ s{^.*/}{};
 496
 497         unless ( defined $cdist ) {
 498             my $d = $distros{ distro_base($short_pdist) };
 499             unless ( defined $d ) {
 500                 print $outfh "\n$module: Can't determine current CPAN entry\n";
 501                 next;
 502             }
 503             if ( keys %$d > 1 ) {
 504                 print $outfh
 505                   "\n$module: (found more than one CPAN candidate):\n";
 506                 print $outfh "    perl: $pdist\n";
 507                 print $outfh "    CPAN: $_\n" for sort keys %$d;
 508                 next;
 509             }
 510             $cdist = ( keys %$d )[0];
 511         }
 512
 513         if ( $cdist ne $pdist ) {
 514             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
 515         }
 516     }
 517 }
 518
 519 # get the EXCLUDED and MAP entries for this module, or
 520 # make up defaults if they don't exist
 521
 522 sub get_map {
 523     my ( $m, $module_name, $perl_files ) = @_;
 524
 525     my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
 526
 527     $excluded   ||= [];
 528     $customized ||= [];
 529
 530     return $excluded, $map, $customized if $map;
 531
 532     # all files under ext/foo-bar (plus maybe some under t/lib)???
 533
 534     my $ext;
 535     for (@$perl_files) {
 536         if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
 537             if ( defined $ext and $ext ne $1 ) {
 538
 539                 # more than one ext/$ext/
 540                 undef $ext;
 541                 last;
 542             }
 543             $ext = $1;
 544         }
 545         elsif (m{^t/lib/}) {
 546             next;
 547         }
 548         else {
 549             undef $ext;
 550             last;
 551         }
 552     }
 553
 554     if ( defined $ext ) {
 555         $map = { '' => $ext },;
 556     }
 557     else {
 558         ( my $base = $module_name ) =~ s{::}{/}g;
 559         $base = "lib/$base";
 560         $map  = {
 561             'lib/' => 'lib/',
 562             ''     => "$base/",
 563         };
 564     }
 565     return $excluded, $map, $customized;
 566 }
 567
 568 # Given an exclude list and a mapping hash, convert a CPAN filename
 569 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
 570 # Returns an empty list for an excluded file
 571
 572 sub cpan_to_perl {
 573     my ( $excluded, $map, $customized, $cpan_file ) = @_;
 574
 575     my %customized = map { ( $_ => 1 ) } @$customized;
 576     for my $exclude (@$excluded) {
 577         next if $customized{$exclude};
 578
 579         # may be a simple string to match exactly, or a pattern
 580         if ( ref $exclude ) {
 581             return if $cpan_file =~ $exclude;
 582         }
 583         else {
 584             return if $cpan_file eq $exclude;
 585         }
 586     }
 587
 588     my $perl_file = $cpan_file;
 589
 590     # try longest prefix first, then alphabetically on tie-break
 591     for
 592       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
 593     {
 594         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
 595     }
 596     return $perl_file;
 597 }
 598
 599 # fetch a file from a URL and store it in a file given by a filename
 600
 601 sub my_getstore {
 602     my ( $url, $file ) = @_;
 603     File::Path::mkpath( File::Basename::dirname($file) );
 604     if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
 605         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
 606         File::Copy::copy( $local_path, $file );
 607     } else {
 608         my $http = HTTP::Tiny->new;
 609         my $response = $http->mirror($url, $file);
 610         return $response->{success};
 611     }
 612 }
 613
 614 # download and unpack a distribution
 615 # Returns the full pathname of the extracted directory
 616 # (eg '/tmp/XYZ/Foo_bar-1.23')
 617
 618 # cache_dir:  where to download the .tar.gz file to
 619 # mirror_url: CPAN mirror to download from
 620 # untar_dir:  where to untar or unzup the file
 621 # module:     name of module
 622 # dist:       name of the distribution
 623
 624 sub get_distribution {
 625     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
 626
 627     $dist =~ m{.+/([^/]+)$}
 628       or die
 629       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
 630     my $filename = $1;
 631
 632     my $download_file = catfile( $src_dir, $filename );
 633
 634     # download distribution
 635
 636     if ( -f $download_file and !-s $download_file ) {
 637
 638         # failed download might leave a zero-length file
 639         unlink $download_file;
 640     }
 641
 642     unless ( -f $download_file ) {
 643
 644         # not cached
 645         my $url = cpan_url_distribution( $mirror_url, $dist );
 646         my_getstore( $url, $download_file )
 647           or die "ERROR: Could not fetch '$url'\n";
 648     }
 649
 650     # get the expected name of the extracted distribution dir
 651
 652     my $path = catfile( $untar_dir, $filename );
 653
 654     $path =~ s/\.tar\.gz$//
 655       or $path =~ s/\.tgz$//
 656       or $path =~ s/\.zip$//
 657       or die
 658       "ERROR: downloaded file does not have a recognised suffix: $path\n";
 659
 660     # extract it unless we already have it cached or tarball is newer
 661     if ( !-d $path || ( -M $download_file < -M $path ) ) {
 662         $path = extract( $download_file, $untar_dir )
 663           or die
 664           "ERROR: failed to extract distribution '$download_file to temp. dir: "
 665           . $! . "\n";
 666     }
 667
 668     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
 669
 670     return $path;
 671 }
 672
 673 # produce the diff of a single file
 674 sub file_diff {
 675     my $outfh     = shift;
 676     my $cpan_file = shift;
 677     my $perl_file = shift;
 678     my $reverse   = shift;
 679     my $diff_opts = shift;
 680
 681     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
 682     if ($reverse) {
 683         push @cmd, $perl_file, $cpan_file;
 684     }
 685     else {
 686         push @cmd, $cpan_file, $perl_file;
 687     }
 688     return `@cmd`;
 689
 690 }
 691
 692 sub customized {
 693     my ( $module_data, $file ) = @_;
 694     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
 695 }
 696
 697 sub extract {
 698   my ($archive,$to) = @_;
 699   my $cwd = cwd();
 700   chdir $to or die "$!\n";
 701   my @files;
 702   EXTRACT: {
 703     local $Archive::Tar::CHOWN = 0;
 704     my $next;
 705     unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
 706        $! = $Archive::Tar::error;
 707        last EXTRACT;
 708     }
 709     while ( my $file = $next->() ) {
 710       push @files, $file->full_path;
 711       unless ( $file->extract ) {
 712         $! = $Archive::Tar::error;
 713         last EXTRACT;
 714       }
 715     }
 716   }
 717   my $path = __get_extract_dir( \@files );
 718   chdir $cwd or die "$!\n";
 719   return $path;
 720 }
 721
 722 sub __get_extract_dir {
 723     my $files   = shift || [];
 724
 725     return unless scalar @$files;
 726
 727     my($dir1, $dir2);
 728     for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
 729         my($dir,$pos) = @$aref;
 730
 731         ### add a catdir(), so that any trailing slashes get
 732         ### take care of (removed)
 733         ### also, a catdir() normalises './dir/foo' to 'dir/foo';
 734         ### which was the problem in bug #23999
 735         my $res = -d $files->[$pos]
 736                     ? File::Spec->catdir( $files->[$pos], '' )
 737                     : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
 738
 739         $$dir = $res;
 740     }
 741
 742     ### if the first and last dir don't match, make sure the
 743     ### dirname is not set wrongly
 744     my $dir;
 745
 746     ### dirs are the same, so we know for sure what the extract dir is
 747     if( $dir1 eq $dir2 ) {
 748         $dir = $dir1;
 749
 750     ### dirs are different.. do they share the base dir?
 751     ### if so, use that, if not, fall back to '.'
 752     } else {
 753         my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
 754         my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
 755
 756         $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
 757     }
 758
 759     return File::Spec->rel2abs( $dir );
 760 }
 761
 762 run();
 763