This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Consistent output from core-cpan-diff
[perl5.git] / Porting / core-cpan-diff
CommitLineData
cb097e7a
DM
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.
e66db76d 6
cb097e7a
DM
7use strict;
8use warnings;
9
10use 5.010;
11
12use Getopt::Long;
a08d2aad 13use File::Basename ();
333797b2
DG
14use File::Copy ();
15use File::Temp ();
16use File::Path ();
97e1df43 17use File::Spec;
c4940a93 18use File::Spec::Functions;
cb097e7a 19use IO::Uncompress::Gunzip ();
333797b2 20use File::Compare ();
cb097e7a 21use ExtUtils::Manifest;
c4940a93 22use ExtUtils::MakeMaker ();
ee682a85 23use HTTP::Tiny;
cb097e7a
DM
24
25BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
26use lib 'Porting';
27use Maintainers ();
28
cb097e7a 29use Archive::Tar;
97e1df43 30use Cwd qw[cwd chdir];
cb097e7a
DM
31use IPC::Open3;
32use IO::Select;
97e1df43 33local $Archive::Tar::WARN=0;
cb097e7a 34
c4940a93 35# where, under the cache dir, to download tarballs to
333797b2
DG
36use constant SRC_DIR => 'tarballs';
37
cb097e7a 38# where, under the cache dir, to untar stuff to
cb097e7a
DM
39use constant UNTAR_DIR => 'untarred';
40
333797b2 41use constant DIFF_CMD => 'diff';
cb097e7a
DM
42
43sub usage {
44 print STDERR "\n@_\n\n" if @_;
45 print STDERR <<HERE;
46Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
47
48-a/--all Scan all dual-life modules.
49
50-c/--cachedir Where to save downloaded CPAN tarball files
51 (defaults to /tmp/something/ with deletion after each run).
52
53-d/--diff Display file differences using diff(1), rather than just
54 listing which files have changed.
cb097e7a
DM
55
56--diffopts Options to pass to the diff command. Defaults to '-u'.
57
58-f|force Force download from CPAN of new 02packages.details.txt file
59 (with --crosscheck only).
60
10be9a51
DG
61-m|mirror Preferred CPAN mirror URI (http:// or file:///)
62 (Local mirror must be a complete mirror, not minicpan)
63
cb097e7a
DM
64-o/--output File name to write output to (defaults to STDOUT).
65
66-r/--reverse Reverses the diff (perl to CPAN).
67
2908b263
RS
68-u/--upstream only print modules with the given upstream (defaults to all)
69
cb097e7a
DM
70-v/--verbose List the fate of *all* files in the tarball, not just those
71 that differ or are missing.
72
73-x|crosscheck List the distributions whose current CPAN version differs from
74 that in blead (i.e. the DISTRIBUTION field in Maintainers.pl).
75
76By default (i.e. without the --crosscheck option), for each listed module
77(or with -a, all CPAN modules listed in Maintainers.pl), grab the tarball
78from CPAN associated with that module, and compare the files in it with
79those in the perl source tree.
80
81Must be run from the root of the perl source tree.
82Module names must match the keys of %Modules in Maintainers.pl.
2760d9b4
SH
83
84The diff(1) command is assumed to be in your PATH and is used to diff files
85regardless of whether the --diff option has been chosen to display any file
86differences.
cb097e7a
DM
87HERE
88 exit(1);
89}
90
cb097e7a
DM
91sub run {
92 my $scan_all;
93 my $diff_opts;
333797b2 94 my $reverse = 0;
2908b263 95 my @wanted_upstreams;
cb097e7a 96 my $cache_dir;
10be9a51 97 my $mirror_url = "http://www.cpan.org/";
cb097e7a
DM
98 my $use_diff;
99 my $output_file;
b056d07f 100 my $verbose = 0;
cb097e7a
DM
101 my $force;
102 my $do_crosscheck;
103
104 GetOptions(
333797b2
DG
105 'a|all' => \$scan_all,
106 'c|cachedir=s' => \$cache_dir,
107 'd|diff' => \$use_diff,
108 'diffopts:s' => \$diff_opts,
109 'f|force' => \$force,
110 'h|help' => \&usage,
111 'm|mirror=s' => \$mirror_url,
112 'o|output=s' => \$output_file,
113 'r|reverse' => \$reverse,
114 'u|upstream=s@' => \@wanted_upstreams,
b056d07f 115 'v|verbose:1' => \$verbose,
333797b2 116 'x|crosscheck' => \$do_crosscheck,
cb097e7a
DM
117 ) or usage;
118
cb097e7a
DM
119 my @modules;
120
121 usage("Cannot mix -a with module list") if $scan_all && @ARGV;
122
123 if ($do_crosscheck) {
b056d07f
MB
124 usage("can't use -r, -d, --diffopts with --crosscheck")
125 if ( $reverse || $use_diff || $diff_opts );
cb097e7a
DM
126 }
127 else {
5f92f74f 128 $diff_opts = '-u -b' unless defined $diff_opts;
333797b2 129 usage("can't use -f without --crosscheck") if $force;
cb097e7a
DM
130 }
131
333797b2
DG
132 @modules =
133 $scan_all
134 ? grep $Maintainers::Modules{$_}{CPAN},
135 ( sort { lc $a cmp lc $b } keys %Maintainers::Modules )
136 : @ARGV;
cb097e7a
DM
137 usage("No modules specified") unless @modules;
138
cb097e7a 139 my $outfh;
333797b2
DG
140 if ( defined $output_file ) {
141 open $outfh, '>', $output_file
142 or die "ERROR: could not open file '$output_file' for writing: $!\n";
cb097e7a
DM
143 }
144 else {
333797b2
DG
145 open $outfh, ">&STDOUT"
146 or die "ERROR: can't dup STDOUT: $!\n";
cb097e7a
DM
147 }
148
333797b2 149 if ( defined $cache_dir ) {
05bdd686
FR
150 die "ERROR: not a directory: '$cache_dir'\n"
151 if !-d $cache_dir && -e $cache_dir;
152 File::Path::mkpath($cache_dir);
cb097e7a 153 }
c4940a93 154 else {
333797b2 155 $cache_dir = File::Temp::tempdir( CLEANUP => 1 );
c4940a93 156 }
cb097e7a 157
333797b2 158 $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/";
91ddc0c8 159 my $test_file = "modules/03modlist.data.gz";
333797b2
DG
160 my_getstore(
161 cpan_url( $mirror_url, $test_file ),
162 catfile( $cache_dir, $test_file )
163 ) or die "ERROR: not a CPAN mirror '$mirror_url'\n";
10be9a51 164
cb097e7a 165 if ($do_crosscheck) {
f5b47b4a 166 do_crosscheck(
b056d07f 167 $outfh, $cache_dir, $mirror_url, $verbose,
f5b47b4a
JL
168 $force, \@modules, \@wanted_upstreams
169 );
cb097e7a
DM
170 }
171 else {
b056d07f 172 $verbose > 2 and $use_diff++;
333797b2
DG
173 do_compare(
174 \@modules, $outfh, $output_file,
175 $cache_dir, $mirror_url, $verbose,
176 $use_diff, $reverse, $diff_opts,
177 \@wanted_upstreams
178 );
cb097e7a
DM
179 }
180}
181
10be9a51 182# construct a CPAN url
cb097e7a 183
10be9a51 184sub cpan_url {
333797b2 185 my ( $mirror_url, @path ) = @_;
10be9a51
DG
186 return $mirror_url unless @path;
187 my $cpan_path = join( "/", map { split "/", $_ } @path );
333797b2 188 $cpan_path =~ s{\A/}{}; # remove leading slash since url has one trailing
10be9a51
DG
189 return $mirror_url . $cpan_path;
190}
cb097e7a 191
dd992221
LB
192# construct a CPAN URL for a author/distribution string like:
193# BINGOS/Archive-Extract-0.52.tar.gz
194
195sub cpan_url_distribution {
196 my ( $mirror_url, $distribution ) = @_;
197 $distribution =~ /^([A-Z])([A-Z])/
198 or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
4109bc0c 199 my $path = "authors/id/$1/$1$2/$distribution";
dd992221
LB
200 return cpan_url( $mirror_url, $path );
201}
202
cb097e7a
DM
203# compare a list of modules against their CPAN equivalents
204
205sub do_compare {
333797b2
DG
206 my (
207 $modules, $outfh, $output_file, $cache_dir,
208 $mirror_url, $verbose, $use_diff, $reverse,
209 $diff_opts, $wanted_upstreams
210 ) = @_;
cb097e7a
DM
211
212 # first, make sure we have a directory where they can all be untarred,
213 # and if its a permanent directory, clear any previous content
333797b2
DG
214 my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
215 my $src_dir = catdir( $cache_dir, SRC_DIR );
c4940a93 216 for my $d ( $src_dir, $untar_dir ) {
333797b2
DG
217 next if -d $d;
218 mkdir $d or die "mkdir $d: $!\n";
cb097e7a
DM
219 }
220
333797b2 221 my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
44ac36ff 222 my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
cb097e7a
DM
223
224 my %seen_dist;
225 for my $module (@$modules) {
333797b2 226 warn "Processing $module ...\n" if defined $output_file;
cb097e7a 227
333797b2
DG
228 my $m = $Maintainers::Modules{$module}
229 or die "ERROR: No such module in Maintainers.pl: '$module'\n";
cb097e7a 230
333797b2
DG
231 unless ( $m->{CPAN} ) {
232 print $outfh "WARNING: $module is not dual-life; skipping\n";
233 next;
234 }
cb097e7a 235
333797b2
DG
236 my $dist = $m->{DISTRIBUTION};
237 die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
cb097e7a 238
333797b2
DG
239 if ( $seen_dist{$dist}++ ) {
240 warn "WARNING: duplicate entry for $dist in $module\n";
241 }
d55832d0 242
25b25355 243 my $upstream = $m->{UPSTREAM} // 'undef';
44ac36ff 244 next if @$wanted_upstreams and !$wanted_upstream{$upstream};
d55832d0 245
333797b2
DG
246 print $outfh "\n$module - "
247 . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
248 print $outfh " upstream is: "
8e188e6b 249 . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
cb097e7a 250
333797b2
DG
251 my $cpan_dir;
252 eval {
253 $cpan_dir =
254 get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
255 $dist );
256 };
257 if ($@) {
258 print $outfh " ", $@;
259 print $outfh " (skipping)\n";
260 next;
261 }
cb097e7a 262
333797b2 263 my @perl_files = Maintainers::get_module_files($module);
cb097e7a 264
333797b2
DG
265 my $manifest = catfile( $cpan_dir, 'MANIFEST' );
266 die "ERROR: no such file: $manifest\n" unless -f $manifest;
cb097e7a 267
333797b2
DG
268 my $cpan_files = ExtUtils::Manifest::maniread($manifest);
269 my @cpan_files = sort keys %$cpan_files;
cb097e7a 270
333797b2 271 ( my $main_pm = $module ) =~ s{::}{/}g;
c4940a93
DG
272 $main_pm .= ".pm";
273
7134fed3
DG
274 my ( $excluded, $map, $customized ) =
275 get_map( $m, $module, \@perl_files );
333797b2
DG
276
277 my %perl_unseen;
278 @perl_unseen{@perl_files} = ();
279 my %perl_files = %perl_unseen;
280
281 foreach my $cpan_file (@cpan_files) {
7134fed3
DG
282 my $mapped_file =
283 cpan_to_perl( $excluded, $map, $customized, $cpan_file );
333797b2
DG
284 unless ( defined $mapped_file ) {
285 print $outfh " Excluded: $cpan_file\n" if $verbose;
286 next;
287 }
288
289 if ( exists $perl_files{$mapped_file} ) {
290 delete $perl_unseen{$mapped_file};
291 }
292 else {
293
294 # some CPAN files foo are stored in core as foo.packed,
295 # which are then unpacked by 'make test_prep'
296 my $packed_file = "$mapped_file.packed";
297 if ( exists $perl_files{$packed_file} ) {
298 if ( !-f $mapped_file and -f $packed_file ) {
299 print $outfh <<EOF;
cb097e7a
DM
300WARNING: $mapped_file not found, but .packed variant exists.
301Perhaps you need to run 'make test_prep'?
302EOF
333797b2
DG
303 next;
304 }
305 delete $perl_unseen{$packed_file};
306 }
307 else {
308 if ( $ignorable{$cpan_file} ) {
309 print $outfh " Ignored: $cpan_file\n" if $verbose;
310 next;
311 }
312
313 unless ($use_diff) {
314 print $outfh " CPAN only: $cpan_file",
315 ( $cpan_file eq $mapped_file )
316 ? "\n"
a50c3591 317 : " (missing $mapped_file)\n";
333797b2
DG
318 }
319 next;
320 }
321 }
322
323 my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
324
325 # should never happen
326 die "ERROR: can't find file $abs_cpan_file\n"
327 unless -f $abs_cpan_file;
328
329 # might happen if the FILES entry in Maintainers.pl is wrong
330 unless ( -f $mapped_file ) {
331 print $outfh "WARNING: perl file not found: $mapped_file\n";
332 next;
333 }
cb097e7a 334
6ec9eada 335 my $relative_mapped_file = relatively_mapped($mapped_file);
c4940a93 336
7134fed3 337 my $different =
5f92f74f
DG
338 file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
339 $diff_opts );
7134fed3 340 if ( $different && customized( $m, $relative_mapped_file ) ) {
b056d07f
MB
341 print $outfh " Customized for blead: $relative_mapped_file\n";
342 if ( $use_diff && $verbose ) {
343 $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
344 print $outfh $different;
4ba81d11
DG
345 }
346 }
7134fed3 347 elsif ($different) {
333797b2 348 if ($use_diff) {
5f92f74f
DG
349 $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
350 print $outfh $different;
333797b2
DG
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 }
7134fed3
DG
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
333797b2
DG
370 }
371 }
24b68a05
DG
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 }
333797b2
DG
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 ) {
6ec9eada
DG
395 my $relative_mapped_file = relatively_mapped($_);
396 if ( customized( $m, $relative_mapped_file ) ) {
24b68a05 397 print $outfh " Customized for blead: $_\n";
6ec9eada
DG
398 }
399 else {
400 print $outfh " Perl only: $_\n" unless $use_diff;
401 }
333797b2 402 }
36333836
SH
403 if ( $verbose ) {
404 foreach my $exclude (@$excluded) {
405 my $seen = 0;
406 foreach my $cpan_file (@cpan_files) {
407 # may be a simple string to match exactly, or a pattern
408 if ( ref $exclude ) {
409 $seen = 1 if $cpan_file =~ $exclude;
410 }
411 else {
412 $seen = 1 if $cpan_file eq $exclude;
413 }
414 last if $seen;
415 }
416 if ( not $seen ) {
417 print $outfh " Unnecessary exclusion: $exclude\n";
418 }
419 }
420 }
cb097e7a
DM
421 }
422}
423
6ec9eada
DG
424sub relatively_mapped {
425 my $relative = shift;
426 $relative =~ s/^(cpan|dist|ext)\/.*?\///;
427 return $relative;
428}
429
cb097e7a
DM
430# given FooBar-1.23_45.tar.gz, return FooBar
431
432sub distro_base {
433 my $d = shift;
434 $d =~ s/\.tar\.gz$//;
435 $d =~ s/\.gip$//;
436 $d =~ s/[\d\-_\.]+$//;
437 return $d;
438}
439
440# process --crosscheck action:
441# ie list all distributions whose CPAN versions differ from that listed in
442# Maintainers.pl
443
444sub do_crosscheck {
f5b47b4a 445 my (
b056d07f 446 $outfh, $cache_dir, $mirror_url, $verbose,
f5b47b4a
JL
447 $force, $modules, $wanted_upstreams,
448 ) = @_;
cb097e7a 449
333797b2 450 my $file = '02packages.details.txt';
cb097e7a 451 my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
333797b2
DG
452 my $path = catfile( $download_dir, $file );
453 my $gzfile = "$path.gz";
cb097e7a
DM
454
455 # grab 02packages.details.txt
456
333797b2 457 my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
cb097e7a 458
333797b2
DG
459 if ( !-f $gzfile or $force ) {
460 unlink $gzfile;
461 my_getstore( $url, $gzfile );
cb097e7a
DM
462 }
463 unlink $path;
333797b2
DG
464 IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
465 or die
466 "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
cb097e7a
DM
467
468 # suck in the data from it
e66db76d 469
cb097e7a 470 open my $fh, '<', $path
333797b2 471 or die "ERROR: open: $file: $!\n";
cb097e7a
DM
472
473 my %distros;
474 my %modules;
475
476 while (<$fh>) {
333797b2
DG
477 next if 1 .. /^$/;
478 chomp;
479 my @f = split ' ', $_;
480 if ( @f != 3 ) {
481 warn
482 "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
483 next;
484 }
485 my $distro = $f[2];
486 $distro =~ s{^[A-Z]/[A-Z]{2}/}{}; # strip leading A/AB/
487 $modules{ $f[0] } = $distro;
488
489 ( my $short_distro = $distro ) =~ s{^.*/}{};
490
491 $distros{ distro_base($short_distro) }{$distro} = 1;
cb097e7a
DM
492 }
493
44ac36ff 494 my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
cb097e7a 495 for my $module (@$modules) {
333797b2
DG
496 my $m = $Maintainers::Modules{$module}
497 or die "ERROR: No such module in Maintainers.pl: '$module'\n";
498
b056d07f
MB
499 $verbose and warn "Checking $module\n";
500
333797b2
DG
501 unless ( $m->{CPAN} ) {
502 print $outfh "\nWARNING: $module is not dual-life; skipping\n";
503 next;
504 }
505
506 # given an entry like
507 # Foo::Bar 1.23 foo-bar-1.23.tar.gz,
508 # first compare the module name against Foo::Bar, and failing that,
509 # against foo-bar
510
511 my $pdist = $m->{DISTRIBUTION};
512 die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
513
25b25355 514 my $upstream = $m->{UPSTREAM} // 'undef';
44ac36ff 515 next if @$wanted_upstreams and !$wanted_upstream{$upstream};
f5b47b4a 516
333797b2
DG
517 my $cdist = $modules{$module};
518 ( my $short_pdist = $pdist ) =~ s{^.*/}{};
519
520 unless ( defined $cdist ) {
521 my $d = $distros{ distro_base($short_pdist) };
522 unless ( defined $d ) {
523 print $outfh "\n$module: Can't determine current CPAN entry\n";
524 next;
525 }
526 if ( keys %$d > 1 ) {
527 print $outfh
528 "\n$module: (found more than one CPAN candidate):\n";
776d1892 529 print $outfh " Perl: $pdist\n";
333797b2
DG
530 print $outfh " CPAN: $_\n" for sort keys %$d;
531 next;
532 }
533 $cdist = ( keys %$d )[0];
534 }
535
536 if ( $cdist ne $pdist ) {
537 print $outfh "\n$module:\n Perl: $pdist\n CPAN: $cdist\n";
538 }
cb097e7a
DM
539 }
540}
541
cb097e7a 542# get the EXCLUDED and MAP entries for this module, or
730ad6b9 543# make up defaults if they don't exist
cb097e7a
DM
544
545sub get_map {
333797b2 546 my ( $m, $module_name, $perl_files ) = @_;
cb097e7a 547
4ba81d11 548 my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
cb097e7a 549
7134fed3 550 $excluded ||= [];
4ba81d11 551 $customized ||= [];
cb097e7a 552
4ba81d11 553 return $excluded, $map, $customized if $map;
cb097e7a
DM
554
555 # all files under ext/foo-bar (plus maybe some under t/lib)???
556
557 my $ext;
558 for (@$perl_files) {
333797b2
DG
559 if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
560 if ( defined $ext and $ext ne $1 ) {
561
562 # more than one ext/$ext/
563 undef $ext;
564 last;
565 }
566 $ext = $1;
567 }
568 elsif (m{^t/lib/}) {
569 next;
570 }
571 else {
572 undef $ext;
573 last;
574 }
cb097e7a 575 }
e66db76d 576
333797b2
DG
577 if ( defined $ext ) {
578 $map = { '' => $ext },;
cb097e7a
DM
579 }
580 else {
333797b2
DG
581 ( my $base = $module_name ) =~ s{::}{/}g;
582 $base = "lib/$base";
583 $map = {
584 'lib/' => 'lib/',
585 '' => "$base/",
586 };
cb097e7a 587 }
4ba81d11 588 return $excluded, $map, $customized;
cb097e7a
DM
589}
590
cb097e7a
DM
591# Given an exclude list and a mapping hash, convert a CPAN filename
592# (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
593# Returns an empty list for an excluded file
594
595sub cpan_to_perl {
4ba81d11 596 my ( $excluded, $map, $customized, $cpan_file ) = @_;
cb097e7a 597
44ac36ff 598 my %customized = map { ( $_ => 1 ) } @$customized;
cb097e7a 599 for my $exclude (@$excluded) {
44ac36ff 600 next if $customized{$exclude};
7134fed3 601
333797b2
DG
602 # may be a simple string to match exactly, or a pattern
603 if ( ref $exclude ) {
604 return if $cpan_file =~ $exclude;
605 }
606 else {
607 return if $cpan_file eq $exclude;
608 }
cb097e7a
DM
609 }
610
611 my $perl_file = $cpan_file;
612
613 # try longest prefix first, then alphabetically on tie-break
333797b2
DG
614 for
615 my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
cb097e7a 616 {
333797b2 617 last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
cb097e7a
DM
618 }
619 return $perl_file;
620}
621
ee682a85 622# fetch a file from a URL and store it in a file given by a filename
cb097e7a
DM
623
624sub my_getstore {
333797b2
DG
625 my ( $url, $file ) = @_;
626 File::Path::mkpath( File::Basename::dirname($file) );
ee682a85 627 if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
333797b2 628 ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
a08d2aad 629 File::Copy::copy( $local_path, $file );
ee682a85
LB
630 } else {
631 my $http = HTTP::Tiny->new;
632 my $response = $http->mirror($url, $file);
633 return $response->{success};
cb097e7a
DM
634 }
635}
636
cb097e7a
DM
637# download and unpack a distribution
638# Returns the full pathname of the extracted directory
639# (eg '/tmp/XYZ/Foo_bar-1.23')
640
10be9a51
DG
641# cache_dir: where to download the .tar.gz file to
642# mirror_url: CPAN mirror to download from
e66db76d 643# untar_dir: where to untar or unzup the file
10be9a51
DG
644# module: name of module
645# dist: name of the distribution
cb097e7a
DM
646
647sub get_distribution {
333797b2 648 my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
cb097e7a
DM
649
650 $dist =~ m{.+/([^/]+)$}
333797b2
DG
651 or die
652 "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
cb097e7a
DM
653 my $filename = $1;
654
333797b2 655 my $download_file = catfile( $src_dir, $filename );
cb097e7a
DM
656
657 # download distribution
658
333797b2
DG
659 if ( -f $download_file and !-s $download_file ) {
660
fbfa7c02 661 # failed download might leave a zero-length file
333797b2 662 unlink $download_file;
cb097e7a
DM
663 }
664
333797b2 665 unless ( -f $download_file ) {
cb097e7a 666
333797b2 667 # not cached
dd992221 668 my $url = cpan_url_distribution( $mirror_url, $dist );
333797b2
DG
669 my_getstore( $url, $download_file )
670 or die "ERROR: Could not fetch '$url'\n";
cb097e7a
DM
671 }
672
c4940a93 673 # get the expected name of the extracted distribution dir
cb097e7a 674
333797b2 675 my $path = catfile( $untar_dir, $filename );
cb097e7a 676
333797b2 677 $path =~ s/\.tar\.gz$//
e959ddd4 678 or $path =~ s/\.tgz$//
333797b2
DG
679 or $path =~ s/\.zip$//
680 or die
681 "ERROR: downloaded file does not have a recognised suffix: $path\n";
cb097e7a 682
c4940a93 683 # extract it unless we already have it cached or tarball is newer
333797b2 684 if ( !-d $path || ( -M $download_file < -M $path ) ) {
97e1df43 685 $path = extract( $download_file, $untar_dir )
333797b2
DG
686 or die
687 "ERROR: failed to extract distribution '$download_file to temp. dir: "
97e1df43 688 . $! . "\n";
c4940a93
DG
689 }
690
cb097e7a
DM
691 die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
692
693 return $path;
694}
695
cb097e7a
DM
696# produce the diff of a single file
697sub file_diff {
698 my $outfh = shift;
699 my $cpan_file = shift;
700 my $perl_file = shift;
701 my $reverse = shift;
702 my $diff_opts = shift;
703
333797b2 704 my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
cb097e7a 705 if ($reverse) {
333797b2 706 push @cmd, $perl_file, $cpan_file;
cb097e7a
DM
707 }
708 else {
333797b2 709 push @cmd, $cpan_file, $perl_file;
cb097e7a 710 }
5f92f74f 711 return `@cmd`;
cb097e7a 712
cb097e7a
DM
713}
714
4ba81d11 715sub customized {
7134fed3
DG
716 my ( $module_data, $file ) = @_;
717 return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
4ba81d11
DG
718}
719
97e1df43
CBW
720sub extract {
721 my ($archive,$to) = @_;
722 my $cwd = cwd();
723 chdir $to or die "$!\n";
724 my @files;
725 EXTRACT: {
726 local $Archive::Tar::CHOWN = 0;
727 my $next;
728 unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
729 $! = $Archive::Tar::error;
730 last EXTRACT;
731 }
732 while ( my $file = $next->() ) {
733 push @files, $file->full_path;
734 unless ( $file->extract ) {
735 $! = $Archive::Tar::error;
736 last EXTRACT;
737 }
738 }
739 }
740 my $path = __get_extract_dir( \@files );
741 chdir $cwd or die "$!\n";
742 return $path;
743}
744
745sub __get_extract_dir {
746 my $files = shift || [];
747
748 return unless scalar @$files;
749
750 my($dir1, $dir2);
751 for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
752 my($dir,$pos) = @$aref;
753
754 ### add a catdir(), so that any trailing slashes get
755 ### take care of (removed)
756 ### also, a catdir() normalises './dir/foo' to 'dir/foo';
757 ### which was the problem in bug #23999
758 my $res = -d $files->[$pos]
759 ? File::Spec->catdir( $files->[$pos], '' )
760 : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
761
762 $$dir = $res;
763 }
764
765 ### if the first and last dir don't match, make sure the
766 ### dirname is not set wrongly
767 my $dir;
768
769 ### dirs are the same, so we know for sure what the extract dir is
770 if( $dir1 eq $dir2 ) {
771 $dir = $dir1;
772
773 ### dirs are different.. do they share the base dir?
774 ### if so, use that, if not, fall back to '.'
775 } else {
776 my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
777 my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
778
779 $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
780 }
781
782 return File::Spec->rel2abs( $dir );
783}
784
cb097e7a
DM
785run();
786