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