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::Temp ();
  14 use File::Path ();
  15 use File::Spec;
  16 use Archive::Extract;
  17 use IO::Uncompress::Gunzip ();
  18 use File::Compare ();
  19 use ExtUtils::Manifest;
  20
  21 BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
  22 use lib 'Porting';
  23 use Maintainers ();
  24
  25 # if running from blead, we may be doing -Ilib, which means when we
  26 # 'chdir /tmp/foo', Archive::Extract may not find Archive::Tar etc.
  27 # So preload the things we need, and tell it to check %INC first:
  28
  29 use Archive::Tar;
  30 use IPC::Open3;
  31 use IO::Select;
  32 $Module::Load::Conditional::CHECK_INC_HASH = 1;
  33 # stop Archive::Extract whinging about lack of Archive::Zip
  34 $Archive::Extract::WARN = 0;
  35
  36
  37 # Files, which if they exist in CPAN but not in perl, will not generate
  38 # an 'Only in CPAN' listing
  39 #
  40 our %IGNORABLE = map { ($_ => 1) }
  41         qw(.cvsignore .dualLivedDiffConfig .gitignore
  42               ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL
  43               CHANGELOG ChangeLog CHANGES Changes COPYING Copying CREDITS
  44               GOALS HISTORY INSTALL INSTALL.SKIP LICENSE Makefile.PL
  45               MANIFEST MANIFEST.SKIP META.yml NEW NOTES ppport.h README
  46               SIGNATURE THANKS TODO Todo VERSION WHATSNEW);
  47
  48 # where, under the cache dir, to untar stuff to
  49
  50 use constant UNTAR_DIR => 'untarred';
  51
  52 use constant DIFF_CMD  => 'diff';
  53 use constant WGET_CMD  => 'wget';
  54
  55 sub usage {
  56     print STDERR "\n@_\n\n" if @_;
  57     print STDERR <<HERE;
  58 Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
  59
  60 -a/--all      Scan all dual-life modules.
  61
  62 -c/--cachedir Where to save downloaded CPAN tarball files
  63               (defaults to /tmp/something/ with deletion after each run).
  64
  65 -d/--diff     Display file differences using diff(1), rather than just
  66               listing which files have changed.
  67               The diff(1) command is assumed to be in your PATH.
  68
  69 --diffopts    Options to pass to the diff command. Defaults to '-u'.
  70
  71 -f|force      Force download from CPAN of new 02packages.details.txt file
  72               (with --crosscheck only).
  73
  74 -o/--output   File name to write output to (defaults to STDOUT).
  75
  76 -r/--reverse  Reverses the diff (perl to CPAN).
  77
  78 -v/--verbose  List the fate of *all* files in the tarball, not just those
  79               that differ or are missing.
  80
  81 -x|crosscheck List the distributions whose current CPAN version differs from
  82               that in blead (i.e. the DISTRIBUTION field in Maintainers.pl).
  83
  84 By default (i.e. without the --crosscheck option),  for each listed module
  85 (or with -a, all CPAN modules listed in Maintainers.pl), grab the tarball
  86 from CPAN associated with that module, and compare the files in it with
  87 those in the perl source tree.
  88
  89 Must be run from the root of the perl source tree.
  90 Module names must match the keys of %Modules in Maintainers.pl.
  91 HERE
  92     exit(1);
  93 }
  94
  95
  96 sub run {
  97     my $scan_all;
  98     my $diff_opts;
  99     my $reverse    = 0;
 100     my $cache_dir;
 101     my $use_diff;
 102     my $output_file;
 103     my $verbose;
 104     my $force;
 105     my $do_crosscheck;
 106
 107     GetOptions(
 108         'a|all'        => \$scan_all,
 109         'c|cachedir=s' => \$cache_dir,
 110         'd|diff'       => \$use_diff,
 111         'diffopts:s'   => \$diff_opts,
 112         'f|force'      => \$force,
 113         'h|help'       => \&usage,
 114         'o|output=s'   => \$output_file,
 115         'r|reverse'    => \$reverse,
 116         'v|verbose'    => \$verbose,
 117         'x|crosscheck' => \$do_crosscheck,
 118     ) or usage;
 119
 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' unless defined $diff_opts;
 131         usage("can't use -f without --crosscheck") if $force;
 132     }
 133
 134     @modules = $scan_all
 135                 ? grep $Maintainers::Modules{$_}{CPAN},
 136                     (sort {lc $a cmp lc $b } keys %Maintainers::Modules)
 137                 : @ARGV;
 138     usage("No modules specified") unless @modules;
 139
 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: no such directory: '$cache_dir'\n" unless -d $cache_dir;
 153     }
 154
 155     if ($do_crosscheck) {
 156         do_crosscheck($outfh, $cache_dir, $force, \@modules);
 157     }
 158     else {
 159         do_compare(\@modules, $outfh, $output_file, $cache_dir, $verbose, $use_diff,
 160             $reverse, $diff_opts);
 161     }
 162 }
 163
 164
 165
 166 # compare a list of modules against their CPAN equivalents
 167
 168 sub do_compare {
 169     my ($modules, $outfh, $output_file, $cache_dir, $verbose,
 170                 $use_diff, $reverse, $diff_opts) = @_;
 171
 172
 173     # first, make sure we have a directory where they can all be untarred,
 174     # and if its a permanent directory, clear any previous content
 175     my $untar_dir;
 176     if ($cache_dir) {
 177         $untar_dir = File::Spec->catdir($cache_dir, UNTAR_DIR);
 178         if (-d $untar_dir) {
 179             File::Path::rmtree($untar_dir)
 180                     or die "failed to remove $untar_dir\n";
 181         }
 182         mkdir $untar_dir
 183             or die "mkdir $untar_dir: $!\n";
 184     }
 185     else {
 186         $untar_dir = File::Temp::tempdir( CLEANUP => 1 );
 187     }
 188
 189     my %ignorable = map { ($_ => 1) } @Maintainers::IGNORABLE;
 190
 191     my %seen_dist;
 192     for my $module (@$modules) {
 193         warn "Processing $module ...\n" if defined $output_file;
 194         print $outfh "\n$module\n" unless $use_diff;
 195
 196         my $m = $Maintainers::Modules{$module}
 197             or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 198
 199         unless ($m->{CPAN}) {
 200             print $outfh "WARNING: $module is not dual-life; skipping\n";
 201             next;
 202         }
 203
 204         my $dist = $m->{DISTRIBUTION};
 205         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
 206
 207         if ($seen_dist{$dist}) {
 208             warn "WARNING: duplicate entry for $dist in $module\n"
 209         }
 210         $seen_dist{$dist}++;
 211
 212         my $cpan_dir;
 213         eval {
 214             $cpan_dir = get_distribution($cache_dir, $untar_dir, $module, $dist)
 215         };
 216         if ($@) {
 217             print $outfh "  ", $@;
 218             print $outfh "  (skipping)\n";
 219             next;
 220         }
 221
 222         my @perl_files = Maintainers::get_module_files($module);
 223
 224         my $manifest = File::Spec->catfile($cpan_dir, 'MANIFEST');
 225         die "ERROR: no such file: $manifest\n" unless  -f $manifest;
 226
 227         my $cpan_files = ExtUtils::Manifest::maniread($manifest);
 228         my @cpan_files = sort keys %$cpan_files;
 229
 230         my ($excluded, $map) =  get_map($m, $module, \@perl_files);
 231
 232         my %perl_unseen;
 233         @perl_unseen{@perl_files} = ();
 234         my %perl_files = %perl_unseen;
 235
 236         foreach my $cpan_file (@cpan_files) {
 237             my $mapped_file = cpan_to_perl($excluded, $map, $cpan_file);
 238             unless (defined $mapped_file) {
 239                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
 240                 next;
 241             }
 242
 243             if (exists $perl_files{$mapped_file}) {
 244                 delete $perl_unseen{$mapped_file};
 245             }
 246             else {
 247                 # some CPAN files foo are stored in core as foo.packed,
 248                 # which are then unpacked by 'make test_prep'
 249                 my $packed_file = "$mapped_file.packed";
 250                 if (exists $perl_files{$packed_file} ) {
 251                     if (! -f $mapped_file and -f $packed_file) {
 252                         print $outfh <<EOF;
 253 WARNING: $mapped_file not found, but .packed variant exists.
 254 Perhaps you need to run 'make test_prep'?
 255 EOF
 256                         next;
 257                     }
 258                     delete $perl_unseen{$packed_file};
 259                 }
 260                 else {
 261                     if ($ignorable{$cpan_file}) {
 262                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
 263                         next;
 264                     }
 265
 266                     unless ($use_diff) {
 267                         print $outfh "  CPAN only: $cpan_file",
 268                             ($cpan_file eq $mapped_file) ? "\n"
 269                                 : " (expected $mapped_file)\n";
 270                     }
 271                     next;
 272                 }
 273             }
 274
 275
 276             my $abs_cpan_file = File::Spec->catfile($cpan_dir, $cpan_file);
 277
 278             # should never happen
 279             die "ERROR: can't find file $abs_cpan_file\n" unless -f $abs_cpan_file;
 280
 281             # might happen if the FILES entry in Maintainers.pl is wrong
 282             unless (-f $mapped_file) {
 283                 print $outfh "WARNING: perl file not found: $mapped_file\n";
 284                 next;
 285             }
 286
 287
 288             if (File::Compare::compare($abs_cpan_file, $mapped_file)) {
 289                 if ($use_diff) {
 290                     file_diff($outfh, $abs_cpan_file, $mapped_file,
 291                                         $reverse, $diff_opts);
 292                 }
 293                 else {
 294                     if ($cpan_file eq $mapped_file) {
 295                         print $outfh "  Modified:  $cpan_file\n";
 296                     }
 297                     else {
 298                         print $outfh "  Modified:  $cpan_file $mapped_file\n";
 299                     }
 300                 }
 301             }
 302             elsif ($verbose) {
 303                     if ($cpan_file eq $mapped_file) {
 304                         print $outfh "  Unchanged: $cpan_file\n";
 305                     }
 306                     else {
 307                         print $outfh "  Unchanged: $cpan_file $mapped_file\n";
 308                     }
 309             }
 310         }
 311         for (sort keys %perl_unseen) {
 312             print $outfh "  Perl only: $_\n" unless $use_diff;
 313         }
 314     }
 315 }
 316
 317 # given FooBar-1.23_45.tar.gz, return FooBar
 318
 319 sub distro_base {
 320     my $d = shift;
 321     $d =~ s/\.tar\.gz$//;
 322     $d =~ s/\.gip$//;
 323     $d =~ s/[\d\-_\.]+$//;
 324     return $d;
 325 }
 326
 327 # process --crosscheck action:
 328 # ie list all distributions whose CPAN versions differ from that listed in
 329 # Maintainers.pl
 330
 331 sub do_crosscheck {
 332     my ($outfh, $cache_dir, $force, $modules) = @_;
 333
 334     my $file = '02packages.details.txt';
 335     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
 336     my $path = File::Spec->catfile($download_dir, $file);
 337     my $gzfile = "$path.gz";
 338
 339     # grab 02packages.details.txt
 340
 341     my $url = 'http://www.cpan.org/modules/02packages.details.txt.gz';
 342
 343     if (! -f $gzfile or $force) {
 344         unlink $gzfile;
 345         my_getstore($url, $gzfile);
 346     }
 347     unlink $path;
 348     IO::Uncompress::Gunzip::gunzip($gzfile, $path)
 349         or die "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
 350
 351     # suck in the data from it
 352
 353     open my $fh, '<', $path
 354         or die "ERROR: open: $file: $!\n";
 355
 356     my %distros;
 357     my %modules;
 358
 359     while (<$fh>) {
 360         next if 1../^$/;
 361         chomp;
 362         my @f = split ' ', $_;
 363         if (@f != 3) {
 364             warn "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
 365             next;
 366         }
 367         my $distro = $f[2];
 368         $distro =~ s{^[A-Z]/[A-Z]{2}/}{}; # strip leading A/AB/
 369         $modules{$f[0]} = $distro;
 370
 371         (my $short_distro = $distro) =~ s{^.*/}{};
 372
 373         $distros{distro_base($short_distro)}{$distro} = 1;
 374     }
 375
 376     for my $module (@$modules) {
 377         my $m = $Maintainers::Modules{$module}
 378             or die "ERROR: No such module in Maintainers.pl: '$module'\n";
 379
 380         unless ($m->{CPAN}) {
 381             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
 382             next;
 383         }
 384
 385         # given an entry like
 386         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
 387         # first compare the module name against Foo::Bar, and failing that,
 388         # against foo-bar
 389
 390         my $pdist = $m->{DISTRIBUTION};
 391         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
 392
 393         my $cdist = $modules{$module};
 394         (my $short_pdist = $pdist) =~ s{^.*/}{};
 395
 396         unless (defined $cdist) {
 397             my $d = $distros{distro_base($short_pdist)};
 398             unless (defined $d) {
 399                 print $outfh "\n$module: Can't determine current CPAN entry\n";
 400                 next;
 401             }
 402             if (keys %$d > 1) {
 403                 print $outfh "\n$module: (found more than one CPAN candidate):\n";
 404                 print $outfh "    perl: $pdist\n";
 405                 print $outfh "    CPAN: $_\n" for sort keys %$d;
 406                 next;
 407             }
 408             $cdist = (keys %$d)[0];
 409         }
 410
 411         if ($cdist ne $pdist) {
 412             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
 413         }
 414     }
 415 }
 416
 417
 418
 419 # get the EXCLUDED and MAP entries for this module, or
 420 # make up defauts if they don't exist
 421
 422 sub get_map {
 423     my ($m, $module_name, $perl_files) = @_;
 424
 425     my ($excluded, $map) = @$m{qw(EXCLUDED MAP)};
 426
 427     $excluded ||= [];
 428
 429     return $excluded, $map if $map;
 430
 431     # all files under ext/foo-bar (plus maybe some under t/lib)???
 432
 433     my $ext;
 434     for (@$perl_files) {
 435         if (m{^(ext/[^/]+/)}) {
 436             if (defined $ext and $ext ne $1) {
 437                 # more than one ext/$ext/
 438                 undef $ext;
 439                 last;
 440             }
 441             $ext = $1;
 442         }
 443         elsif (m{^t/lib/}) {
 444             next;
 445         }
 446         else {
 447             undef $ext;
 448             last;
 449         }
 450     }
 451
 452     if (defined $ext) {
 453             $map = { '' => $ext },
 454     }
 455     else {
 456         (my $base = $module_name) =~ s{::}{/}g;
 457         $base ="lib/$base";
 458         $map = {
 459             'lib/'      => 'lib/',
 460             ''  => "$base/",
 461         };
 462     }
 463     return $excluded, $map;
 464 }
 465
 466
 467 # Given an exclude list and a mapping hash, convert a CPAN filename
 468 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
 469 # Returns an empty list for an excluded file
 470
 471 sub cpan_to_perl {
 472     my ($excluded, $map, $cpan_file) = @_;
 473
 474     for my $exclude (@$excluded) {
 475         # may be a simple string to match exactly, or a pattern
 476         if (ref $exclude) {
 477             return if $cpan_file =~ $exclude;
 478         }
 479         else {
 480             return if $cpan_file eq $exclude;
 481         }
 482     }
 483
 484     my $perl_file = $cpan_file;
 485
 486     # try longest prefix first, then alphabetically on tie-break
 487     for my $prefix (sort { length($b) <=> length($a) || $a cmp $b } keys %$map)
 488     {
 489         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
 490     }
 491     return $perl_file;
 492 }
 493
 494
 495
 496 # do LWP::Simple::getstore, possibly without LWP::Simple being available
 497
 498 my $lwp_simple_available;
 499
 500 sub my_getstore {
 501     my ($url, $file) = @_;
 502     unless (defined $lwp_simple_available) {
 503         eval { require LWP::Simple };
 504         $lwp_simple_available = $@ eq '';
 505     }
 506     if ($lwp_simple_available) {
 507         return LWP::Simple::is_success(LWP::Simple::getstore($url, $file));
 508     }
 509     else {
 510         return system(WGET_CMD, "-O", $file, $url) == 0;
 511     }
 512 }
 513
 514
 515 # download and unpack a distribution
 516 # Returns the full pathname of the extracted directory
 517 # (eg '/tmp/XYZ/Foo_bar-1.23')
 518
 519 # cache_dir: where to dowenload the .tar.gz file to
 520 # untar_dir: where to untar or unzup the file
 521 # module:    name of module
 522 # dist:      name of the distribution
 523
 524 sub get_distribution {
 525     my ($cache_dir, $untar_dir, $module, $dist) = @_;
 526
 527     $dist =~ m{.+/([^/]+)$}
 528         or die "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
 529     my $filename = $1;
 530
 531     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
 532     my $download_file = File::Spec->catfile($download_dir, $filename);
 533
 534     # download distribution
 535
 536     if (-f $download_file and ! -s $download_file ) {
 537         # wget can leave a zero-length file on failed download
 538         unlink $download_file;
 539     }
 540
 541     unless (-f $download_file) {
 542         # not cached
 543         $dist =~ /^([A-Z])([A-Z])/
 544             or die "ERROR: $module: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $dist\n";
 545
 546         my $url = "http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist";
 547         my_getstore($url, $download_file)
 548             or die "ERROR: Could not fetch '$url'\n";
 549     }
 550
 551     # extract distribution
 552
 553     my $ae = Archive::Extract->new( archive => $download_file);
 554     $ae->extract( to => $untar_dir )
 555         or die "ERROR: failed to extract distribution '$download_file to temp. dir: " . $ae->error() . "\n";
 556
 557     # get the name of the extracted distribution dir
 558
 559     my $path = File::Spec->catfile($untar_dir, $filename);
 560
 561     $path =~ s/\.tar\.gz$// or
 562     $path =~ s/\.zip$// or
 563       die "ERROR: downloaded file does not have a recognised suffix: $path\n";
 564
 565     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
 566
 567     return $path;
 568 }
 569
 570
 571 # produce the diff of a single file
 572 sub file_diff {
 573     my $outfh     = shift;
 574     my $cpan_file = shift;
 575     my $perl_file = shift;
 576     my $reverse   = shift;
 577     my $diff_opts = shift;
 578
 579
 580     my @cmd = (DIFF_CMD, split ' ', $diff_opts);
 581     if ($reverse) {
 582         push @cmd, $perl_file, $cpan_file;
 583     }
 584     else {
 585         push @cmd, $cpan_file, $perl_file;
 586     }
 587     my $result = `@cmd`;
 588
 589     $result =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
 590
 591     print $outfh $result;
 592 }
 593
 594
 595 run();
 596