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