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