teach sync-with-cpan how to update Maintainers.pl
[perl.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 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 # if running from blead, we may be doing -Ilib, which means when we
30 # 'chdir /tmp/foo', Archive::Extract may not find Archive::Tar etc.
31 # So preload the things we need, and tell it to check %INC first:
32
33 use Archive::Tar;
34 use IPC::Open3;
35 use IO::Select;
36 $Module::Load::Conditional::CHECK_INC_HASH = 1;
37
38 # stop Archive::Extract whinging about lack of Archive::Zip
39 $Archive::Extract::WARN = 0;
40
41 # where, under the cache dir, to download tarballs to
42 use constant SRC_DIR => 'tarballs';
43
44 # where, under the cache dir, to untar stuff to
45 use constant UNTAR_DIR => 'untarred';
46
47 use constant DIFF_CMD => 'diff';
48 use constant WGET_CMD => 'wget';
49
50 sub usage {
51     print STDERR "\n@_\n\n" if @_;
52     print STDERR <<HERE;
53 Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
54
55 -a/--all      Scan all dual-life modules.
56
57 -c/--cachedir Where to save downloaded CPAN tarball files
58               (defaults to /tmp/something/ with deletion after each run).
59
60 -d/--diff     Display file differences using diff(1), rather than just
61               listing which files have changed.
62               The diff(1) command is assumed to be in your PATH.
63
64 --diffopts    Options to pass to the diff command. Defaults to '-u'.
65
66 -f|force      Force download from CPAN of new 02packages.details.txt file
67               (with --crosscheck only).
68
69 -m|mirror     Preferred CPAN mirror URI (http:// or file:///)
70               (Local mirror must be a complete mirror, not minicpan)
71
72 -o/--output   File name to write output to (defaults to STDOUT).
73
74 -r/--reverse  Reverses the diff (perl to CPAN).
75
76 -u/--upstream only print modules with the given upstream (defaults to all)
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 sub run {
96     my $scan_all;
97     my $diff_opts;
98     my $reverse = 0;
99     my @wanted_upstreams;
100     my $cache_dir;
101     my $mirror_url = "http://www.cpan.org/";
102     my $use_diff;
103     my $output_file;
104     my $verbose;
105     my $force;
106     my $do_crosscheck;
107
108     GetOptions(
109         'a|all'         => \$scan_all,
110         'c|cachedir=s'  => \$cache_dir,
111         'd|diff'        => \$use_diff,
112         'diffopts:s'    => \$diff_opts,
113         'f|force'       => \$force,
114         'h|help'        => \&usage,
115         'm|mirror=s'    => \$mirror_url,
116         'o|output=s'    => \$output_file,
117         'r|reverse'     => \$reverse,
118         'u|upstream=s@' => \@wanted_upstreams,
119         'v|verbose'     => \$verbose,
120         'x|crosscheck'  => \$do_crosscheck,
121     ) or usage;
122
123     @wanted_upstreams = map { $_ eq 'undef' ? undef : $_ } @wanted_upstreams;
124
125     my @modules;
126
127     usage("Cannot mix -a with module list") if $scan_all && @ARGV;
128
129     if ($do_crosscheck) {
130         usage("can't use -r, -d, --diffopts, -v with --crosscheck")
131           if ( $reverse || $use_diff || $diff_opts || $verbose );
132     }
133     else {
134         $diff_opts = '-u -b' unless defined $diff_opts;
135         usage("can't use -f without --crosscheck") if $force;
136     }
137
138     @modules =
139       $scan_all
140       ? grep $Maintainers::Modules{$_}{CPAN},
141       ( sort { lc $a cmp lc $b } keys %Maintainers::Modules )
142       : @ARGV;
143     usage("No modules specified") unless @modules;
144
145     my $outfh;
146     if ( defined $output_file ) {
147         open $outfh, '>', $output_file
148           or die "ERROR: could not open file '$output_file' for writing: $!\n";
149     }
150     else {
151         open $outfh, ">&STDOUT"
152           or die "ERROR: can't dup STDOUT: $!\n";
153     }
154
155     if ( defined $cache_dir ) {
156         die "ERROR: no such directory: '$cache_dir'\n" unless -d $cache_dir;
157     }
158     else {
159         $cache_dir = File::Temp::tempdir( CLEANUP => 1 );
160     }
161
162     $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/";
163     my $test_file = "modules/03modlist.data.gz";
164     my_getstore(
165         cpan_url( $mirror_url, $test_file ),
166         catfile( $cache_dir, $test_file )
167     ) or die "ERROR: not a CPAN mirror '$mirror_url'\n";
168
169     if ($do_crosscheck) {
170         do_crosscheck(
171             $outfh, $cache_dir, $mirror_url,
172             $force, \@modules,  \@wanted_upstreams
173         );
174     }
175     else {
176         do_compare(
177             \@modules,  $outfh,      $output_file,
178             $cache_dir, $mirror_url, $verbose,
179             $use_diff,  $reverse,    $diff_opts,
180             \@wanted_upstreams
181         );
182     }
183 }
184
185 # construct a CPAN url
186
187 sub cpan_url {
188     my ( $mirror_url, @path ) = @_;
189     return $mirror_url unless @path;
190     my $cpan_path = join( "/", map { split "/", $_ } @path );
191     $cpan_path =~ s{\A/}{};    # remove leading slash since url has one trailing
192     return $mirror_url . $cpan_path;
193 }
194
195 # construct a CPAN URL for a author/distribution string like:
196 # BINGOS/Archive-Extract-0.52.tar.gz
197
198 sub cpan_url_distribution {
199     my ( $mirror_url, $distribution ) = @_;
200     $distribution =~ /^([A-Z])([A-Z])/
201         or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
202     my $path = "authors/id/$1/$1$2/$distribution";
203     return cpan_url( $mirror_url, $path );
204 }
205
206 # compare a list of modules against their CPAN equivalents
207
208 sub do_compare {
209     my (
210         $modules,    $outfh,   $output_file, $cache_dir,
211         $mirror_url, $verbose, $use_diff,    $reverse,
212         $diff_opts,  $wanted_upstreams
213     ) = @_;
214
215     # first, make sure we have a directory where they can all be untarred,
216     # and if its a permanent directory, clear any previous content
217     my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
218     my $src_dir   = catdir( $cache_dir, SRC_DIR );
219     for my $d ( $src_dir, $untar_dir ) {
220         next if -d $d;
221         mkdir $d or die "mkdir $d: $!\n";
222     }
223
224     my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
225
226     my %seen_dist;
227     for my $module (@$modules) {
228         warn "Processing $module ...\n" if defined $output_file;
229
230         my $m = $Maintainers::Modules{$module}
231           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
232
233         unless ( $m->{CPAN} ) {
234             print $outfh "WARNING: $module is not dual-life; skipping\n";
235             next;
236         }
237
238         my $dist = $m->{DISTRIBUTION};
239         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
240
241         if ( $seen_dist{$dist}++ ) {
242             warn "WARNING: duplicate entry for $dist in $module\n";
243         }
244
245         my $upstream = $m->{UPSTREAM};
246         next if @$wanted_upstreams and !( $upstream ~~ $wanted_upstreams );
247
248         print $outfh "\n$module - "
249           . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
250         print $outfh "  upstream is: "
251           . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
252
253         my $cpan_dir;
254         eval {
255             $cpan_dir =
256               get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
257                 $dist );
258         };
259         if ($@) {
260             print $outfh "  ", $@;
261             print $outfh "  (skipping)\n";
262             next;
263         }
264
265         my @perl_files = Maintainers::get_module_files($module);
266
267         my $manifest = catfile( $cpan_dir, 'MANIFEST' );
268         die "ERROR: no such file: $manifest\n" unless -f $manifest;
269
270         my $cpan_files = ExtUtils::Manifest::maniread($manifest);
271         my @cpan_files = sort keys %$cpan_files;
272
273         ( my $main_pm = $module ) =~ s{::}{/}g;
274         $main_pm .= ".pm";
275
276         my ( $excluded, $map, $customized ) =
277           get_map( $m, $module, \@perl_files );
278
279         my %perl_unseen;
280         @perl_unseen{@perl_files} = ();
281         my %perl_files = %perl_unseen;
282
283         foreach my $cpan_file (@cpan_files) {
284             my $mapped_file =
285               cpan_to_perl( $excluded, $map, $customized, $cpan_file );
286             unless ( defined $mapped_file ) {
287                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
288                 next;
289             }
290
291             if ( exists $perl_files{$mapped_file} ) {
292                 delete $perl_unseen{$mapped_file};
293             }
294             else {
295
296                 # some CPAN files foo are stored in core as foo.packed,
297                 # which are then unpacked by 'make test_prep'
298                 my $packed_file = "$mapped_file.packed";
299                 if ( exists $perl_files{$packed_file} ) {
300                     if ( !-f $mapped_file and -f $packed_file ) {
301                         print $outfh <<EOF;
302 WARNING: $mapped_file not found, but .packed variant exists.
303 Perhaps you need to run 'make test_prep'?
304 EOF
305                         next;
306                     }
307                     delete $perl_unseen{$packed_file};
308                 }
309                 else {
310                     if ( $ignorable{$cpan_file} ) {
311                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
312                         next;
313                     }
314
315                     unless ($use_diff) {
316                         print $outfh "  CPAN only: $cpan_file",
317                           ( $cpan_file eq $mapped_file )
318                           ? "\n"
319                           : " (missing $mapped_file)\n";
320                     }
321                     next;
322                 }
323             }
324
325             my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
326
327             # should never happen
328             die "ERROR: can't find file $abs_cpan_file\n"
329               unless -f $abs_cpan_file;
330
331             # might happen if the FILES entry in Maintainers.pl is wrong
332             unless ( -f $mapped_file ) {
333                 print $outfh "WARNING: perl file not found: $mapped_file\n";
334                 next;
335             }
336
337             my $relative_mapped_file = relatively_mapped($mapped_file);
338
339             my $different =
340               file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
341                 $diff_opts );
342             if ( $different && customized( $m, $relative_mapped_file ) ) {
343                 if (! $use_diff ) {
344                     print $outfh "  Customized for blead: $relative_mapped_file\n";
345                 }
346             }
347             elsif ($different) {
348                 if ($use_diff) {
349                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
350                     print $outfh $different;
351                 }
352                 else {
353                     if ( $cpan_file eq $relative_mapped_file ) {
354                         print $outfh "  Modified:  $relative_mapped_file\n";
355                     }
356                     else {
357                         print $outfh
358                           "  Modified:  $cpan_file $relative_mapped_file\n";
359                     }
360
361                     if ( $cpan_file =~ m{\.pm\z} ) {
362                         my $pv = MM->parse_version($mapped_file)   || 'unknown';
363                         my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
364                         if ( $pv ne $cv ) {
365                             print $outfh
366 "  Version mismatch in '$cpan_file':\n    $cv (cpan) vs $pv (perl)\n";
367                         }
368                     }
369
370                 }
371             }
372             elsif ( customized( $m, $relative_mapped_file ) ) {
373                 # Maintainers.pl says we customized it, but it looks the
374                 # same as CPAN so maybe we lost the customization, which
375                 # could be bad
376                 if ( $cpan_file eq $relative_mapped_file ) {
377                     print $outfh "  Blead customization missing: $cpan_file\n";
378                 }
379                 else {
380                     print $outfh
381                       "  Blead customization missing: $cpan_file $relative_mapped_file\n";
382                 }
383             }
384             elsif ($verbose) {
385                 if ( $cpan_file eq $relative_mapped_file ) {
386                     print $outfh "  Unchanged: $cpan_file\n";
387                 }
388                 else {
389                     print $outfh
390                       "  Unchanged: $cpan_file $relative_mapped_file\n";
391                 }
392             }
393         }
394         for ( sort keys %perl_unseen ) {
395             my $relative_mapped_file = relatively_mapped($_);
396             if ( customized( $m, $relative_mapped_file ) ) {
397                 print $outfh "  Customized for blead: $_\n";
398             }
399             else {
400                 print $outfh "  Perl only: $_\n" unless $use_diff;
401             }
402         }
403     }
404 }
405
406 sub relatively_mapped {
407     my $relative = shift;
408     $relative =~ s/^(cpan|dist|ext)\/.*?\///;
409     return $relative;
410 }
411
412 # given FooBar-1.23_45.tar.gz, return FooBar
413
414 sub distro_base {
415     my $d = shift;
416     $d =~ s/\.tar\.gz$//;
417     $d =~ s/\.gip$//;
418     $d =~ s/[\d\-_\.]+$//;
419     return $d;
420 }
421
422 # process --crosscheck action:
423 # ie list all distributions whose CPAN versions differ from that listed in
424 # Maintainers.pl
425
426 sub do_crosscheck {
427     my (
428         $outfh, $cache_dir, $mirror_url,
429         $force, $modules,   $wanted_upstreams,
430     ) = @_;
431
432     my $file         = '02packages.details.txt';
433     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
434     my $path         = catfile( $download_dir, $file );
435     my $gzfile       = "$path.gz";
436
437     # grab 02packages.details.txt
438
439     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
440
441     if ( !-f $gzfile or $force ) {
442         unlink $gzfile;
443         my_getstore( $url, $gzfile );
444     }
445     unlink $path;
446     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
447       or die
448       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
449
450     # suck in the data from it
451
452     open my $fh, '<', $path
453       or die "ERROR: open: $file: $!\n";
454
455     my %distros;
456     my %modules;
457
458     while (<$fh>) {
459         next if 1 .. /^$/;
460         chomp;
461         my @f = split ' ', $_;
462         if ( @f != 3 ) {
463             warn
464               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
465             next;
466         }
467         my $distro = $f[2];
468         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
469         $modules{ $f[0] } = $distro;
470
471         ( my $short_distro = $distro ) =~ s{^.*/}{};
472
473         $distros{ distro_base($short_distro) }{$distro} = 1;
474     }
475
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 !( $upstream ~~ $wanted_upstreams );
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 defauts 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     for my $exclude (@$excluded) {
578         next if $exclude ~~ $customized;
579
580         # may be a simple string to match exactly, or a pattern
581         if ( ref $exclude ) {
582             return if $cpan_file =~ $exclude;
583         }
584         else {
585             return if $cpan_file eq $exclude;
586         }
587     }
588
589     my $perl_file = $cpan_file;
590
591     # try longest prefix first, then alphabetically on tie-break
592     for
593       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
594     {
595         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
596     }
597     return $perl_file;
598 }
599
600 # fetch a file from a URL and store it in a file given by a filename
601
602 sub my_getstore {
603     my ( $url, $file ) = @_;
604     File::Path::mkpath( File::Basename::dirname($file) );
605     if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
606         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
607         File::Copy::copy( $local_path, $file );
608     } else {
609         my $http = HTTP::Tiny->new;
610         my $response = $http->mirror($url, $file);
611         return $response->{success};
612     }
613 }
614
615 # download and unpack a distribution
616 # Returns the full pathname of the extracted directory
617 # (eg '/tmp/XYZ/Foo_bar-1.23')
618
619 # cache_dir:  where to download the .tar.gz file to
620 # mirror_url: CPAN mirror to download from
621 # untar_dir:  where to untar or unzup the file
622 # module:     name of module
623 # dist:       name of the distribution
624
625 sub get_distribution {
626     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
627
628     $dist =~ m{.+/([^/]+)$}
629       or die
630       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
631     my $filename = $1;
632
633     my $download_file = catfile( $src_dir, $filename );
634
635     # download distribution
636
637     if ( -f $download_file and !-s $download_file ) {
638
639         # wget can leave a zero-length file on failed download
640         unlink $download_file;
641     }
642
643     unless ( -f $download_file ) {
644
645         # not cached
646         my $url = cpan_url_distribution( $mirror_url, $dist );
647         my_getstore( $url, $download_file )
648           or die "ERROR: Could not fetch '$url'\n";
649     }
650
651     # get the expected name of the extracted distribution dir
652
653     my $path = catfile( $untar_dir, $filename );
654
655     $path =~ s/\.tar\.gz$//
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         my $ae = Archive::Extract->new( archive => $download_file );
663         $ae->extract( to => $untar_dir )
664           or die
665           "ERROR: failed to extract distribution '$download_file to temp. dir: "
666           . $ae->error() . "\n";
667
668         $path = $ae->extract_path;
669     }
670
671     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
672
673     return $path;
674 }
675
676 # produce the diff of a single file
677 sub file_diff {
678     my $outfh     = shift;
679     my $cpan_file = shift;
680     my $perl_file = shift;
681     my $reverse   = shift;
682     my $diff_opts = shift;
683
684     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
685     if ($reverse) {
686         push @cmd, $perl_file, $cpan_file;
687     }
688     else {
689         push @cmd, $cpan_file, $perl_file;
690     }
691     return `@cmd`;
692
693 }
694
695 sub customized {
696     my ( $module_data, $file ) = @_;
697     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
698 }
699
700 run();
701