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 | ||
12 | use Getopt::Long; | |
a08d2aad | 13 | use File::Basename (); |
333797b2 DG |
14 | use File::Copy (); |
15 | use File::Temp (); | |
16 | use File::Path (); | |
c4940a93 | 17 | use File::Spec::Functions; |
cb097e7a DM |
18 | use Archive::Extract; |
19 | use IO::Uncompress::Gunzip (); | |
333797b2 | 20 | use File::Compare (); |
cb097e7a | 21 | use ExtUtils::Manifest; |
c4940a93 | 22 | use ExtUtils::MakeMaker (); |
cb097e7a DM |
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; | |
333797b2 | 36 | |
cb097e7a DM |
37 | # stop Archive::Extract whinging about lack of Archive::Zip |
38 | $Archive::Extract::WARN = 0; | |
39 | ||
c4940a93 | 40 | # where, under the cache dir, to download tarballs to |
333797b2 DG |
41 | use constant SRC_DIR => 'tarballs'; |
42 | ||
cb097e7a | 43 | # where, under the cache dir, to untar stuff to |
cb097e7a DM |
44 | use constant UNTAR_DIR => 'untarred'; |
45 | ||
333797b2 DG |
46 | use constant DIFF_CMD => 'diff'; |
47 | use constant WGET_CMD => 'wget'; | |
cb097e7a DM |
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 | ||
10be9a51 DG |
68 | -m|mirror Preferred CPAN mirror URI (http:// or file:///) |
69 | (Local mirror must be a complete mirror, not minicpan) | |
70 | ||
cb097e7a DM |
71 | -o/--output File name to write output to (defaults to STDOUT). |
72 | ||
73 | -r/--reverse Reverses the diff (perl to CPAN). | |
74 | ||
2908b263 RS |
75 | -u/--upstream only print modules with the given upstream (defaults to all) |
76 | ||
cb097e7a DM |
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 | ||
cb097e7a DM |
94 | sub run { |
95 | my $scan_all; | |
96 | my $diff_opts; | |
333797b2 | 97 | my $reverse = 0; |
2908b263 | 98 | my @wanted_upstreams; |
cb097e7a | 99 | my $cache_dir; |
10be9a51 | 100 | my $mirror_url = "http://www.cpan.org/"; |
cb097e7a DM |
101 | my $use_diff; |
102 | my $output_file; | |
103 | my $verbose; | |
104 | my $force; | |
105 | my $do_crosscheck; | |
106 | ||
107 | GetOptions( | |
333797b2 DG |
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, | |
cb097e7a DM |
120 | ) or usage; |
121 | ||
cb097e7a DM |
122 | my @modules; |
123 | ||
124 | usage("Cannot mix -a with module list") if $scan_all && @ARGV; | |
125 | ||
126 | if ($do_crosscheck) { | |
333797b2 DG |
127 | usage("can't use -r, -d, --diffopts, -v with --crosscheck") |
128 | if ( $reverse || $use_diff || $diff_opts || $verbose ); | |
cb097e7a DM |
129 | } |
130 | else { | |
5f92f74f | 131 | $diff_opts = '-u -b' unless defined $diff_opts; |
333797b2 | 132 | usage("can't use -f without --crosscheck") if $force; |
cb097e7a DM |
133 | } |
134 | ||
333797b2 DG |
135 | @modules = |
136 | $scan_all | |
137 | ? grep $Maintainers::Modules{$_}{CPAN}, | |
138 | ( sort { lc $a cmp lc $b } keys %Maintainers::Modules ) | |
139 | : @ARGV; | |
cb097e7a DM |
140 | usage("No modules specified") unless @modules; |
141 | ||
cb097e7a | 142 | my $outfh; |
333797b2 DG |
143 | if ( defined $output_file ) { |
144 | open $outfh, '>', $output_file | |
145 | or die "ERROR: could not open file '$output_file' for writing: $!\n"; | |
cb097e7a DM |
146 | } |
147 | else { | |
333797b2 DG |
148 | open $outfh, ">&STDOUT" |
149 | or die "ERROR: can't dup STDOUT: $!\n"; | |
cb097e7a DM |
150 | } |
151 | ||
333797b2 DG |
152 | if ( defined $cache_dir ) { |
153 | die "ERROR: no such directory: '$cache_dir'\n" unless -d $cache_dir; | |
cb097e7a | 154 | } |
c4940a93 | 155 | else { |
333797b2 | 156 | $cache_dir = File::Temp::tempdir( CLEANUP => 1 ); |
c4940a93 | 157 | } |
cb097e7a | 158 | |
333797b2 | 159 | $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/"; |
10be9a51 | 160 | my $test_file = "modules/07mirror.yml"; |
333797b2 DG |
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"; | |
10be9a51 | 165 | |
cb097e7a | 166 | if ($do_crosscheck) { |
333797b2 | 167 | do_crosscheck( $outfh, $cache_dir, $mirror_url, $force, \@modules ); |
cb097e7a DM |
168 | } |
169 | else { | |
333797b2 DG |
170 | do_compare( |
171 | \@modules, $outfh, $output_file, | |
172 | $cache_dir, $mirror_url, $verbose, | |
173 | $use_diff, $reverse, $diff_opts, | |
174 | \@wanted_upstreams | |
175 | ); | |
cb097e7a DM |
176 | } |
177 | } | |
178 | ||
10be9a51 | 179 | # construct a CPAN url |
cb097e7a | 180 | |
10be9a51 | 181 | sub cpan_url { |
333797b2 | 182 | my ( $mirror_url, @path ) = @_; |
10be9a51 DG |
183 | return $mirror_url unless @path; |
184 | my $cpan_path = join( "/", map { split "/", $_ } @path ); | |
333797b2 | 185 | $cpan_path =~ s{\A/}{}; # remove leading slash since url has one trailing |
10be9a51 DG |
186 | return $mirror_url . $cpan_path; |
187 | } | |
cb097e7a DM |
188 | |
189 | # compare a list of modules against their CPAN equivalents | |
190 | ||
191 | sub do_compare { | |
333797b2 DG |
192 | my ( |
193 | $modules, $outfh, $output_file, $cache_dir, | |
194 | $mirror_url, $verbose, $use_diff, $reverse, | |
195 | $diff_opts, $wanted_upstreams | |
196 | ) = @_; | |
cb097e7a DM |
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 | |
333797b2 DG |
200 | my $untar_dir = catdir( $cache_dir, UNTAR_DIR ); |
201 | my $src_dir = catdir( $cache_dir, SRC_DIR ); | |
c4940a93 | 202 | for my $d ( $src_dir, $untar_dir ) { |
333797b2 DG |
203 | next if -d $d; |
204 | mkdir $d or die "mkdir $d: $!\n"; | |
cb097e7a DM |
205 | } |
206 | ||
333797b2 | 207 | my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE; |
cb097e7a DM |
208 | |
209 | my %seen_dist; | |
210 | for my $module (@$modules) { | |
333797b2 | 211 | warn "Processing $module ...\n" if defined $output_file; |
cb097e7a | 212 | |
333797b2 DG |
213 | my $m = $Maintainers::Modules{$module} |
214 | or die "ERROR: No such module in Maintainers.pl: '$module'\n"; | |
cb097e7a | 215 | |
333797b2 DG |
216 | unless ( $m->{CPAN} ) { |
217 | print $outfh "WARNING: $module is not dual-life; skipping\n"; | |
218 | next; | |
219 | } | |
cb097e7a | 220 | |
333797b2 DG |
221 | my $dist = $m->{DISTRIBUTION}; |
222 | die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist; | |
cb097e7a | 223 | |
333797b2 DG |
224 | if ( $seen_dist{$dist}++ ) { |
225 | warn "WARNING: duplicate entry for $dist in $module\n"; | |
226 | } | |
d55832d0 | 227 | |
333797b2 DG |
228 | my $upstream = $m->{UPSTREAM} || 'UNKNOWN'; |
229 | next if @$wanted_upstreams and !( $upstream ~~ $wanted_upstreams ); | |
d55832d0 | 230 | |
333797b2 DG |
231 | print $outfh "\n$module - " |
232 | . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n"; | |
233 | print $outfh " upstream is: " | |
234 | . ( $m->{UPSTREAM} || 'UNKNOWN!' ) . "\n"; | |
cb097e7a | 235 | |
333797b2 DG |
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 | } | |
cb097e7a | 247 | |
333797b2 | 248 | my @perl_files = Maintainers::get_module_files($module); |
cb097e7a | 249 | |
333797b2 DG |
250 | my $manifest = catfile( $cpan_dir, 'MANIFEST' ); |
251 | die "ERROR: no such file: $manifest\n" unless -f $manifest; | |
cb097e7a | 252 | |
333797b2 DG |
253 | my $cpan_files = ExtUtils::Manifest::maniread($manifest); |
254 | my @cpan_files = sort keys %$cpan_files; | |
cb097e7a | 255 | |
333797b2 | 256 | ( my $main_pm = $module ) =~ s{::}{/}g; |
c4940a93 DG |
257 | $main_pm .= ".pm"; |
258 | ||
7134fed3 DG |
259 | my ( $excluded, $map, $customized ) = |
260 | get_map( $m, $module, \@perl_files ); | |
333797b2 DG |
261 | |
262 | my %perl_unseen; | |
263 | @perl_unseen{@perl_files} = (); | |
264 | my %perl_files = %perl_unseen; | |
265 | ||
266 | foreach my $cpan_file (@cpan_files) { | |
7134fed3 DG |
267 | my $mapped_file = |
268 | cpan_to_perl( $excluded, $map, $customized, $cpan_file ); | |
333797b2 DG |
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; | |
cb097e7a DM |
285 | WARNING: $mapped_file not found, but .packed variant exists. |
286 | Perhaps you need to run 'make test_prep'? | |
287 | EOF | |
333797b2 DG |
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 | } | |
cb097e7a | 319 | |
c4940a93 DG |
320 | my $relative_mapped_file = $mapped_file; |
321 | $relative_mapped_file =~ s/^(cpan|dist|ext)\/.*?\///; | |
322 | ||
7134fed3 | 323 | my $different = |
5f92f74f DG |
324 | file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse, |
325 | $diff_opts ); | |
7134fed3 | 326 | if ( $different && customized( $m, $relative_mapped_file ) ) { |
4ba81d11 DG |
327 | if ($verbose) { |
328 | print $outfh " Customized: $relative_mapped_file\n"; | |
329 | } | |
330 | } | |
7134fed3 | 331 | elsif ($different) { |
333797b2 | 332 | if ($use_diff) { |
5f92f74f DG |
333 | $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm; |
334 | print $outfh $different; | |
333797b2 DG |
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 | } | |
7134fed3 DG |
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 | ||
333797b2 DG |
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 | } | |
cb097e7a DM |
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 { | |
333797b2 | 387 | my ( $outfh, $cache_dir, $mirror_url, $force, $modules ) = @_; |
cb097e7a | 388 | |
333797b2 | 389 | my $file = '02packages.details.txt'; |
cb097e7a | 390 | my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 ); |
333797b2 DG |
391 | my $path = catfile( $download_dir, $file ); |
392 | my $gzfile = "$path.gz"; | |
cb097e7a DM |
393 | |
394 | # grab 02packages.details.txt | |
395 | ||
333797b2 | 396 | my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" ); |
cb097e7a | 397 | |
333797b2 DG |
398 | if ( !-f $gzfile or $force ) { |
399 | unlink $gzfile; | |
400 | my_getstore( $url, $gzfile ); | |
cb097e7a DM |
401 | } |
402 | unlink $path; | |
333797b2 DG |
403 | IO::Uncompress::Gunzip::gunzip( $gzfile, $path ) |
404 | or die | |
405 | "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n"; | |
cb097e7a DM |
406 | |
407 | # suck in the data from it | |
e66db76d | 408 | |
cb097e7a | 409 | open my $fh, '<', $path |
333797b2 | 410 | or die "ERROR: open: $file: $!\n"; |
cb097e7a DM |
411 | |
412 | my %distros; | |
413 | my %modules; | |
414 | ||
415 | while (<$fh>) { | |
333797b2 DG |
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; | |
cb097e7a DM |
431 | } |
432 | ||
433 | for my $module (@$modules) { | |
333797b2 DG |
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 | } | |
cb097e7a DM |
472 | } |
473 | } | |
474 | ||
cb097e7a DM |
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 { | |
333797b2 | 479 | my ( $m, $module_name, $perl_files ) = @_; |
cb097e7a | 480 | |
4ba81d11 | 481 | my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)}; |
cb097e7a | 482 | |
7134fed3 | 483 | $excluded ||= []; |
4ba81d11 | 484 | $customized ||= []; |
cb097e7a | 485 | |
4ba81d11 | 486 | return $excluded, $map, $customized if $map; |
cb097e7a DM |
487 | |
488 | # all files under ext/foo-bar (plus maybe some under t/lib)??? | |
489 | ||
490 | my $ext; | |
491 | for (@$perl_files) { | |
333797b2 DG |
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 | } | |
cb097e7a | 508 | } |
e66db76d | 509 | |
333797b2 DG |
510 | if ( defined $ext ) { |
511 | $map = { '' => $ext },; | |
cb097e7a DM |
512 | } |
513 | else { | |
333797b2 DG |
514 | ( my $base = $module_name ) =~ s{::}{/}g; |
515 | $base = "lib/$base"; | |
516 | $map = { | |
517 | 'lib/' => 'lib/', | |
518 | '' => "$base/", | |
519 | }; | |
cb097e7a | 520 | } |
4ba81d11 | 521 | return $excluded, $map, $customized; |
cb097e7a DM |
522 | } |
523 | ||
cb097e7a DM |
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 { | |
4ba81d11 | 529 | my ( $excluded, $map, $customized, $cpan_file ) = @_; |
cb097e7a DM |
530 | |
531 | for my $exclude (@$excluded) { | |
4ba81d11 | 532 | next if $exclude ~~ $customized; |
7134fed3 | 533 | |
333797b2 DG |
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 | } | |
cb097e7a DM |
541 | } |
542 | ||
543 | my $perl_file = $cpan_file; | |
544 | ||
545 | # try longest prefix first, then alphabetically on tie-break | |
333797b2 DG |
546 | for |
547 | my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map ) | |
cb097e7a | 548 | { |
333797b2 | 549 | last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/; |
cb097e7a DM |
550 | } |
551 | return $perl_file; | |
552 | } | |
553 | ||
cb097e7a DM |
554 | # do LWP::Simple::getstore, possibly without LWP::Simple being available |
555 | ||
556 | my $lwp_simple_available; | |
557 | ||
558 | sub my_getstore { | |
333797b2 DG |
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 ''; | |
cb097e7a DM |
564 | } |
565 | if ($lwp_simple_available) { | |
333797b2 | 566 | return LWP::Simple::is_success( LWP::Simple::getstore( $url, $file ) ); |
cb097e7a | 567 | } |
a08d2aad | 568 | elsif ( $url =~ qr{\Afile://(?:localhost)?/} ) { |
333797b2 | 569 | ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{}; |
a08d2aad DG |
570 | File::Copy::copy( $local_path, $file ); |
571 | } | |
cb097e7a | 572 | else { |
333797b2 | 573 | return system( WGET_CMD, "-O", $file, $url ) == 0; |
cb097e7a DM |
574 | } |
575 | } | |
576 | ||
cb097e7a DM |
577 | # download and unpack a distribution |
578 | # Returns the full pathname of the extracted directory | |
579 | # (eg '/tmp/XYZ/Foo_bar-1.23') | |
580 | ||
10be9a51 DG |
581 | # cache_dir: where to download the .tar.gz file to |
582 | # mirror_url: CPAN mirror to download from | |
e66db76d | 583 | # untar_dir: where to untar or unzup the file |
10be9a51 DG |
584 | # module: name of module |
585 | # dist: name of the distribution | |
cb097e7a DM |
586 | |
587 | sub get_distribution { | |
333797b2 | 588 | my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_; |
cb097e7a DM |
589 | |
590 | $dist =~ m{.+/([^/]+)$} | |
333797b2 DG |
591 | or die |
592 | "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n"; | |
cb097e7a DM |
593 | my $filename = $1; |
594 | ||
333797b2 | 595 | my $download_file = catfile( $src_dir, $filename ); |
cb097e7a DM |
596 | |
597 | # download distribution | |
598 | ||
333797b2 DG |
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; | |
cb097e7a DM |
603 | } |
604 | ||
333797b2 | 605 | unless ( -f $download_file ) { |
cb097e7a | 606 | |
333797b2 DG |
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"; | |
cb097e7a DM |
616 | } |
617 | ||
c4940a93 | 618 | # get the expected name of the extracted distribution dir |
cb097e7a | 619 | |
333797b2 | 620 | my $path = catfile( $untar_dir, $filename ); |
cb097e7a | 621 | |
333797b2 DG |
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"; | |
cb097e7a | 626 | |
c4940a93 | 627 | # extract it unless we already have it cached or tarball is newer |
333797b2 DG |
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"; | |
45c9b306 FR |
634 | |
635 | $path = $ae->extract_path; | |
c4940a93 DG |
636 | } |
637 | ||
cb097e7a DM |
638 | die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path; |
639 | ||
640 | return $path; | |
641 | } | |
642 | ||
cb097e7a DM |
643 | # produce the diff of a single file |
644 | sub file_diff { | |
645 | my $outfh = shift; | |
646 | my $cpan_file = shift; | |
647 | my $perl_file = shift; | |
648 | my $reverse = shift; | |
649 | my $diff_opts = shift; | |
650 | ||
333797b2 | 651 | my @cmd = ( DIFF_CMD, split ' ', $diff_opts ); |
cb097e7a | 652 | if ($reverse) { |
333797b2 | 653 | push @cmd, $perl_file, $cpan_file; |
cb097e7a DM |
654 | } |
655 | else { | |
333797b2 | 656 | push @cmd, $cpan_file, $perl_file; |
cb097e7a | 657 | } |
5f92f74f | 658 | return `@cmd`; |
cb097e7a | 659 | |
cb097e7a DM |
660 | } |
661 | ||
4ba81d11 | 662 | sub customized { |
7134fed3 DG |
663 | my ( $module_data, $file ) = @_; |
664 | return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} }; | |
4ba81d11 DG |
665 | } |
666 | ||
cb097e7a DM |
667 | run(); |
668 |