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