RT #74436: [PATCH] Add -Wwrite-strings
[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
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 -b' 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, $customized ) =
260           get_map( $m, $module, \@perl_files );
261
262         my %perl_unseen;
263         @perl_unseen{@perl_files} = ();
264         my %perl_files = %perl_unseen;
265
266         foreach my $cpan_file (@cpan_files) {
267             my $mapped_file =
268               cpan_to_perl( $excluded, $map, $customized, $cpan_file );
269             unless ( defined $mapped_file ) {
270                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
271                 next;
272             }
273
274             if ( exists $perl_files{$mapped_file} ) {
275                 delete $perl_unseen{$mapped_file};
276             }
277             else {
278
279                 # some CPAN files foo are stored in core as foo.packed,
280                 # which are then unpacked by 'make test_prep'
281                 my $packed_file = "$mapped_file.packed";
282                 if ( exists $perl_files{$packed_file} ) {
283                     if ( !-f $mapped_file and -f $packed_file ) {
284                         print $outfh <<EOF;
285 WARNING: $mapped_file not found, but .packed variant exists.
286 Perhaps you need to run 'make test_prep'?
287 EOF
288                         next;
289                     }
290                     delete $perl_unseen{$packed_file};
291                 }
292                 else {
293                     if ( $ignorable{$cpan_file} ) {
294                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
295                         next;
296                     }
297
298                     unless ($use_diff) {
299                         print $outfh "  CPAN only: $cpan_file",
300                           ( $cpan_file eq $mapped_file )
301                           ? "\n"
302                           : " (expected $mapped_file)\n";
303                     }
304                     next;
305                 }
306             }
307
308             my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
309
310             # should never happen
311             die "ERROR: can't find file $abs_cpan_file\n"
312               unless -f $abs_cpan_file;
313
314             # might happen if the FILES entry in Maintainers.pl is wrong
315             unless ( -f $mapped_file ) {
316                 print $outfh "WARNING: perl file not found: $mapped_file\n";
317                 next;
318             }
319
320             my $relative_mapped_file = $mapped_file;
321             $relative_mapped_file =~ s/^(cpan|dist|ext)\/.*?\///;
322
323             my $different =
324               file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
325                 $diff_opts );
326             if ( $different && customized( $m, $relative_mapped_file ) ) {
327                 if ($verbose) {
328                     print $outfh "  Customized: $relative_mapped_file\n";
329                 }
330             }
331             elsif ($different) {
332                 if ($use_diff) {
333                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
334                     print $outfh $different;
335                 }
336                 else {
337                     if ( $cpan_file eq $relative_mapped_file ) {
338                         print $outfh "  Modified:  $relative_mapped_file\n";
339                     }
340                     else {
341                         print $outfh
342                           "  Modified:  $cpan_file $relative_mapped_file\n";
343                     }
344
345                     if ( $cpan_file =~ m{\.pm\z} ) {
346                         my $pv = MM->parse_version($mapped_file)   || 'unknown';
347                         my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
348                         if ( $pv ne $cv ) {
349                             print $outfh
350 "  Version mismatch in '$cpan_file':\n    $cv (cpan) vs $pv (perl)\n";
351                         }
352                     }
353
354                 }
355             }
356             elsif ($verbose) {
357                 if ( $cpan_file eq $relative_mapped_file ) {
358                     print $outfh "  Unchanged: $cpan_file\n";
359                 }
360                 else {
361                     print $outfh
362                       "  Unchanged: $cpan_file $relative_mapped_file\n";
363                 }
364             }
365         }
366         for ( sort keys %perl_unseen ) {
367             print $outfh "  Perl only: $_\n" unless $use_diff;
368         }
369     }
370 }
371
372 # given FooBar-1.23_45.tar.gz, return FooBar
373
374 sub distro_base {
375     my $d = shift;
376     $d =~ s/\.tar\.gz$//;
377     $d =~ s/\.gip$//;
378     $d =~ s/[\d\-_\.]+$//;
379     return $d;
380 }
381
382 # process --crosscheck action:
383 # ie list all distributions whose CPAN versions differ from that listed in
384 # Maintainers.pl
385
386 sub do_crosscheck {
387     my ( $outfh, $cache_dir, $mirror_url, $force, $modules ) = @_;
388
389     my $file         = '02packages.details.txt';
390     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
391     my $path         = catfile( $download_dir, $file );
392     my $gzfile       = "$path.gz";
393
394     # grab 02packages.details.txt
395
396     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
397
398     if ( !-f $gzfile or $force ) {
399         unlink $gzfile;
400         my_getstore( $url, $gzfile );
401     }
402     unlink $path;
403     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
404       or die
405       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
406
407     # suck in the data from it
408
409     open my $fh, '<', $path
410       or die "ERROR: open: $file: $!\n";
411
412     my %distros;
413     my %modules;
414
415     while (<$fh>) {
416         next if 1 .. /^$/;
417         chomp;
418         my @f = split ' ', $_;
419         if ( @f != 3 ) {
420             warn
421               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
422             next;
423         }
424         my $distro = $f[2];
425         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
426         $modules{ $f[0] } = $distro;
427
428         ( my $short_distro = $distro ) =~ s{^.*/}{};
429
430         $distros{ distro_base($short_distro) }{$distro} = 1;
431     }
432
433     for my $module (@$modules) {
434         my $m = $Maintainers::Modules{$module}
435           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
436
437         unless ( $m->{CPAN} ) {
438             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
439             next;
440         }
441
442         # given an entry like
443         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
444         # first compare the module name against Foo::Bar, and failing that,
445         # against foo-bar
446
447         my $pdist = $m->{DISTRIBUTION};
448         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
449
450         my $cdist = $modules{$module};
451         ( my $short_pdist = $pdist ) =~ s{^.*/}{};
452
453         unless ( defined $cdist ) {
454             my $d = $distros{ distro_base($short_pdist) };
455             unless ( defined $d ) {
456                 print $outfh "\n$module: Can't determine current CPAN entry\n";
457                 next;
458             }
459             if ( keys %$d > 1 ) {
460                 print $outfh
461                   "\n$module: (found more than one CPAN candidate):\n";
462                 print $outfh "    perl: $pdist\n";
463                 print $outfh "    CPAN: $_\n" for sort keys %$d;
464                 next;
465             }
466             $cdist = ( keys %$d )[0];
467         }
468
469         if ( $cdist ne $pdist ) {
470             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
471         }
472     }
473 }
474
475 # get the EXCLUDED and MAP entries for this module, or
476 # make up defauts if they don't exist
477
478 sub get_map {
479     my ( $m, $module_name, $perl_files ) = @_;
480
481     my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
482
483     $excluded   ||= [];
484     $customized ||= [];
485
486     return $excluded, $map, $customized if $map;
487
488     # all files under ext/foo-bar (plus maybe some under t/lib)???
489
490     my $ext;
491     for (@$perl_files) {
492         if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
493             if ( defined $ext and $ext ne $1 ) {
494
495                 # more than one ext/$ext/
496                 undef $ext;
497                 last;
498             }
499             $ext = $1;
500         }
501         elsif (m{^t/lib/}) {
502             next;
503         }
504         else {
505             undef $ext;
506             last;
507         }
508     }
509
510     if ( defined $ext ) {
511         $map = { '' => $ext },;
512     }
513     else {
514         ( my $base = $module_name ) =~ s{::}{/}g;
515         $base = "lib/$base";
516         $map  = {
517             'lib/' => 'lib/',
518             ''     => "$base/",
519         };
520     }
521     return $excluded, $map, $customized;
522 }
523
524 # Given an exclude list and a mapping hash, convert a CPAN filename
525 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
526 # Returns an empty list for an excluded file
527
528 sub cpan_to_perl {
529     my ( $excluded, $map, $customized, $cpan_file ) = @_;
530
531     for my $exclude (@$excluded) {
532         next if $exclude ~~ $customized;
533
534         # may be a simple string to match exactly, or a pattern
535         if ( ref $exclude ) {
536             return if $cpan_file =~ $exclude;
537         }
538         else {
539             return if $cpan_file eq $exclude;
540         }
541     }
542
543     my $perl_file = $cpan_file;
544
545     # try longest prefix first, then alphabetically on tie-break
546     for
547       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
548     {
549         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
550     }
551     return $perl_file;
552 }
553
554 # do LWP::Simple::getstore, possibly without LWP::Simple being available
555
556 my $lwp_simple_available;
557
558 sub my_getstore {
559     my ( $url, $file ) = @_;
560     File::Path::mkpath( File::Basename::dirname($file) );
561     unless ( defined $lwp_simple_available ) {
562         eval { require LWP::Simple };
563         $lwp_simple_available = $@ eq '';
564     }
565     if ($lwp_simple_available) {
566         return LWP::Simple::is_success( LWP::Simple::getstore( $url, $file ) );
567     }
568     elsif ( $url =~ qr{\Afile://(?:localhost)?/} ) {
569         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
570         File::Copy::copy( $local_path, $file );
571     }
572     else {
573         return system( WGET_CMD, "-O", $file, $url ) == 0;
574     }
575 }
576
577 # download and unpack a distribution
578 # Returns the full pathname of the extracted directory
579 # (eg '/tmp/XYZ/Foo_bar-1.23')
580
581 # cache_dir:  where to download the .tar.gz file to
582 # mirror_url: CPAN mirror to download from
583 # untar_dir:  where to untar or unzup the file
584 # module:     name of module
585 # dist:       name of the distribution
586
587 sub get_distribution {
588     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
589
590     $dist =~ m{.+/([^/]+)$}
591       or die
592       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
593     my $filename = $1;
594
595     my $download_file = catfile( $src_dir, $filename );
596
597     # download distribution
598
599     if ( -f $download_file and !-s $download_file ) {
600
601         # wget can leave a zero-length file on failed download
602         unlink $download_file;
603     }
604
605     unless ( -f $download_file ) {
606
607         # not cached
608         $dist =~ /^([A-Z])([A-Z])/
609           or die
610 "ERROR: $module: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $dist\n";
611
612         my $url =
613           cpan_url( $mirror_url, "modules/by-authors/id/$1/$1$2/$dist" );
614         my_getstore( $url, $download_file )
615           or die "ERROR: Could not fetch '$url'\n";
616     }
617
618     # get the expected name of the extracted distribution dir
619
620     my $path = catfile( $untar_dir, $filename );
621
622     $path =~ s/\.tar\.gz$//
623       or $path =~ s/\.zip$//
624       or die
625       "ERROR: downloaded file does not have a recognised suffix: $path\n";
626
627     # extract it unless we already have it cached or tarball is newer
628     if ( !-d $path || ( -M $download_file < -M $path ) ) {
629         my $ae = Archive::Extract->new( archive => $download_file );
630         $ae->extract( to => $untar_dir )
631           or die
632           "ERROR: failed to extract distribution '$download_file to temp. dir: "
633           . $ae->error() . "\n";
634     }
635
636     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
637
638     return $path;
639 }
640
641 # produce the diff of a single file
642 sub file_diff {
643     my $outfh     = shift;
644     my $cpan_file = shift;
645     my $perl_file = shift;
646     my $reverse   = shift;
647     my $diff_opts = shift;
648
649     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
650     if ($reverse) {
651         push @cmd, $perl_file, $cpan_file;
652     }
653     else {
654         push @cmd, $cpan_file, $perl_file;
655     }
656     return `@cmd`;
657
658 }
659
660 sub customized {
661     my ( $module_data, $file ) = @_;
662     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
663 }
664
665 run();
666