| 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; |
| 18 | use File::Spec::Functions; |
| 19 | use IO::Uncompress::Gunzip (); |
| 20 | use File::Compare (); |
| 21 | use ExtUtils::Manifest; |
| 22 | use ExtUtils::MakeMaker (); |
| 23 | use HTTP::Tiny; |
| 24 | |
| 25 | BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' } |
| 26 | use lib 'Porting'; |
| 27 | use Maintainers (); |
| 28 | |
| 29 | use Archive::Tar; |
| 30 | use Cwd qw[cwd chdir]; |
| 31 | use IPC::Open3; |
| 32 | use IO::Select; |
| 33 | local $Archive::Tar::WARN=0; |
| 34 | |
| 35 | # where, under the cache dir, to download tarballs to |
| 36 | use constant SRC_DIR => 'tarballs'; |
| 37 | |
| 38 | # where, under the cache dir, to untar stuff to |
| 39 | use constant UNTAR_DIR => 'untarred'; |
| 40 | |
| 41 | use constant DIFF_CMD => 'diff'; |
| 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 | |
| 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. |
| 55 | |
| 56 | --diffopts Options to pass to the diff command. Defaults to '-u --binary'. |
| 57 | |
| 58 | -f|force Force download from CPAN of new 02packages.details.txt file |
| 59 | (with --crosscheck only). |
| 60 | |
| 61 | -m|mirror Preferred CPAN mirror URI (http:// or file:///) |
| 62 | (Local mirror must be a complete mirror, not minicpan) |
| 63 | |
| 64 | -o/--output File name to write output to (defaults to STDOUT). |
| 65 | |
| 66 | -r/--reverse Reverses the diff (perl to CPAN). |
| 67 | |
| 68 | -u/--upstream only print modules with the given upstream (defaults to all) |
| 69 | |
| 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 | |
| 76 | By 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 |
| 78 | from CPAN associated with that module, and compare the files in it with |
| 79 | those in the perl source tree. |
| 80 | |
| 81 | Must be run from the root of the perl source tree. |
| 82 | Module names must match the keys of %Modules in Maintainers.pl. |
| 83 | |
| 84 | The diff(1) command is assumed to be in your PATH and is used to diff files |
| 85 | regardless of whether the --diff option has been chosen to display any file |
| 86 | differences. |
| 87 | HERE |
| 88 | exit(1); |
| 89 | } |
| 90 | |
| 91 | sub run { |
| 92 | my $scan_all; |
| 93 | my $diff_opts; |
| 94 | my $reverse = 0; |
| 95 | my @wanted_upstreams; |
| 96 | my $cache_dir; |
| 97 | my $mirror_url = "http://www.cpan.org/"; |
| 98 | my $use_diff; |
| 99 | my $output_file; |
| 100 | my $verbose = 0; |
| 101 | my $force; |
| 102 | my $do_crosscheck; |
| 103 | |
| 104 | GetOptions( |
| 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, |
| 115 | 'v|verbose:1' => \$verbose, |
| 116 | 'x|crosscheck' => \$do_crosscheck, |
| 117 | ) or usage; |
| 118 | |
| 119 | my @modules; |
| 120 | |
| 121 | usage("Cannot mix -a with module list") if $scan_all && @ARGV; |
| 122 | |
| 123 | if ($do_crosscheck) { |
| 124 | usage("can't use -r, -d, --diffopts with --crosscheck") |
| 125 | if ( $reverse || $use_diff || $diff_opts ); |
| 126 | } |
| 127 | else { |
| 128 | $diff_opts = '-u --binary' unless defined $diff_opts; |
| 129 | usage("can't use -f without --crosscheck") if $force; |
| 130 | } |
| 131 | |
| 132 | @modules = |
| 133 | $scan_all |
| 134 | ? grep $Maintainers::Modules{$_}{CPAN}, |
| 135 | ( sort { lc $a cmp lc $b } keys %Maintainers::Modules ) |
| 136 | : @ARGV; |
| 137 | usage("No modules specified") unless @modules; |
| 138 | |
| 139 | my $outfh; |
| 140 | if ( defined $output_file ) { |
| 141 | open $outfh, '>', $output_file |
| 142 | or die "ERROR: could not open file '$output_file' for writing: $!\n"; |
| 143 | } |
| 144 | else { |
| 145 | open $outfh, ">&STDOUT" |
| 146 | or die "ERROR: can't dup STDOUT: $!\n"; |
| 147 | } |
| 148 | |
| 149 | if ( defined $cache_dir ) { |
| 150 | die "ERROR: not a directory: '$cache_dir'\n" |
| 151 | if !-d $cache_dir && -e $cache_dir; |
| 152 | File::Path::mkpath($cache_dir); |
| 153 | } |
| 154 | else { |
| 155 | $cache_dir = File::Temp::tempdir( CLEANUP => 1 ); |
| 156 | } |
| 157 | |
| 158 | $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/"; |
| 159 | my $test_file = "modules/03modlist.data.gz"; |
| 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"; |
| 164 | |
| 165 | if ($do_crosscheck) { |
| 166 | do_crosscheck( |
| 167 | $outfh, $cache_dir, $mirror_url, $verbose, |
| 168 | $force, \@modules, \@wanted_upstreams |
| 169 | ); |
| 170 | } |
| 171 | else { |
| 172 | $verbose > 2 and $use_diff++; |
| 173 | do_compare( |
| 174 | \@modules, $outfh, $output_file, |
| 175 | $cache_dir, $mirror_url, $verbose, |
| 176 | $use_diff, $reverse, $diff_opts, |
| 177 | \@wanted_upstreams |
| 178 | ); |
| 179 | } |
| 180 | } |
| 181 | |
| 182 | # construct a CPAN url |
| 183 | |
| 184 | sub cpan_url { |
| 185 | my ( $mirror_url, @path ) = @_; |
| 186 | return $mirror_url unless @path; |
| 187 | my $cpan_path = join( "/", map { split "/", $_ } @path ); |
| 188 | $cpan_path =~ s{\A/}{}; # remove leading slash since url has one trailing |
| 189 | return $mirror_url . $cpan_path; |
| 190 | } |
| 191 | |
| 192 | # construct a CPAN URL for a author/distribution string like: |
| 193 | # BINGOS/Archive-Extract-0.52.tar.gz |
| 194 | |
| 195 | sub 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"; |
| 199 | my $path = "authors/id/$1/$1$2/$distribution"; |
| 200 | return cpan_url( $mirror_url, $path ); |
| 201 | } |
| 202 | |
| 203 | # compare a list of modules against their CPAN equivalents |
| 204 | |
| 205 | sub do_compare { |
| 206 | my ( |
| 207 | $modules, $outfh, $output_file, $cache_dir, |
| 208 | $mirror_url, $verbose, $use_diff, $reverse, |
| 209 | $diff_opts, $wanted_upstreams |
| 210 | ) = @_; |
| 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 |
| 214 | my $untar_dir = catdir( $cache_dir, UNTAR_DIR ); |
| 215 | my $src_dir = catdir( $cache_dir, SRC_DIR ); |
| 216 | for my $d ( $src_dir, $untar_dir ) { |
| 217 | next if -d $d; |
| 218 | mkdir $d or die "mkdir $d: $!\n"; |
| 219 | } |
| 220 | |
| 221 | my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE; |
| 222 | my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams; |
| 223 | |
| 224 | my %seen_dist; |
| 225 | for my $module (@$modules) { |
| 226 | warn "Processing $module ...\n" if defined $output_file; |
| 227 | |
| 228 | my $m = $Maintainers::Modules{$module} |
| 229 | or die "ERROR: No such module in Maintainers.pl: '$module'\n"; |
| 230 | |
| 231 | unless ( $m->{CPAN} ) { |
| 232 | print $outfh "WARNING: $module is not dual-life; skipping\n"; |
| 233 | next; |
| 234 | } |
| 235 | |
| 236 | my $dist = $m->{DISTRIBUTION}; |
| 237 | die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist; |
| 238 | |
| 239 | if ( $seen_dist{$dist}++ ) { |
| 240 | warn "WARNING: duplicate entry for $dist in $module\n"; |
| 241 | } |
| 242 | |
| 243 | my $upstream = $m->{UPSTREAM} // 'undef'; |
| 244 | next if @$wanted_upstreams and !$wanted_upstream{$upstream}; |
| 245 | |
| 246 | print $outfh "\n$module - " |
| 247 | . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n"; |
| 248 | print $outfh " upstream is: " |
| 249 | . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n"; |
| 250 | |
| 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 | } |
| 262 | |
| 263 | my @perl_files = Maintainers::get_module_files($module); |
| 264 | |
| 265 | my $manifest = catfile( $cpan_dir, 'MANIFEST' ); |
| 266 | die "ERROR: no such file: $manifest\n" unless -f $manifest; |
| 267 | |
| 268 | my $cpan_files = ExtUtils::Manifest::maniread($manifest); |
| 269 | my @cpan_files = sort keys %$cpan_files; |
| 270 | |
| 271 | ( my $main_pm = $module ) =~ s{::}{/}g; |
| 272 | $main_pm .= ".pm"; |
| 273 | |
| 274 | my ( $excluded, $map, $customized ) = |
| 275 | get_map( $m, $module, \@perl_files ); |
| 276 | |
| 277 | my %perl_unseen; |
| 278 | @perl_unseen{@perl_files} = (); |
| 279 | my %perl_files = %perl_unseen; |
| 280 | |
| 281 | foreach my $cpan_file (@cpan_files) { |
| 282 | my $mapped_file = |
| 283 | cpan_to_perl( $excluded, $map, $customized, $cpan_file ); |
| 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; |
| 300 | WARNING: $mapped_file not found, but .packed variant exists. |
| 301 | Perhaps you need to run 'make test_prep'? |
| 302 | EOF |
| 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" |
| 317 | : " (missing $mapped_file)\n"; |
| 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 | } |
| 334 | |
| 335 | my $relative_mapped_file = relatively_mapped($mapped_file); |
| 336 | |
| 337 | my $different = |
| 338 | file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse, |
| 339 | $diff_opts ); |
| 340 | if ( $different && customized( $m, $relative_mapped_file ) ) { |
| 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; |
| 345 | } |
| 346 | } |
| 347 | elsif ($different) { |
| 348 | if ($use_diff) { |
| 349 | $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm; |
| 350 | print $outfh $different; |
| 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 | } |
| 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 | |
| 370 | } |
| 371 | } |
| 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 | } |
| 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 ) { |
| 395 | my $relative_mapped_file = relatively_mapped($_); |
| 396 | if ( customized( $m, $relative_mapped_file ) ) { |
| 397 | print $outfh " Customized for blead: $_\n"; |
| 398 | } |
| 399 | else { |
| 400 | print $outfh " Perl only: $_\n" unless $use_diff; |
| 401 | } |
| 402 | } |
| 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 | } |
| 421 | } |
| 422 | } |
| 423 | |
| 424 | sub relatively_mapped { |
| 425 | my $relative = shift; |
| 426 | $relative =~ s/^(cpan|dist|ext)\/.*?\///; |
| 427 | return $relative; |
| 428 | } |
| 429 | |
| 430 | # given FooBar-1.23_45.tar.gz, return FooBar |
| 431 | |
| 432 | sub 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 | |
| 444 | sub do_crosscheck { |
| 445 | my ( |
| 446 | $outfh, $cache_dir, $mirror_url, $verbose, |
| 447 | $force, $modules, $wanted_upstreams, |
| 448 | ) = @_; |
| 449 | |
| 450 | my $file = '02packages.details.txt'; |
| 451 | my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 ); |
| 452 | my $path = catfile( $download_dir, $file ); |
| 453 | my $gzfile = "$path.gz"; |
| 454 | |
| 455 | # grab 02packages.details.txt |
| 456 | |
| 457 | my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" ); |
| 458 | |
| 459 | if ( !-f $gzfile or $force ) { |
| 460 | unlink $gzfile; |
| 461 | my_getstore( $url, $gzfile ); |
| 462 | } |
| 463 | unlink $path; |
| 464 | IO::Uncompress::Gunzip::gunzip( $gzfile, $path ) |
| 465 | or die |
| 466 | "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n"; |
| 467 | |
| 468 | # suck in the data from it |
| 469 | |
| 470 | open my $fh, '<', $path |
| 471 | or die "ERROR: open: $file: $!\n"; |
| 472 | |
| 473 | my %distros; |
| 474 | my %modules; |
| 475 | |
| 476 | while (<$fh>) { |
| 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; |
| 492 | } |
| 493 | |
| 494 | my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams; |
| 495 | for my $module (@$modules) { |
| 496 | my $m = $Maintainers::Modules{$module} |
| 497 | or die "ERROR: No such module in Maintainers.pl: '$module'\n"; |
| 498 | |
| 499 | $verbose and warn "Checking $module\n"; |
| 500 | |
| 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 | |
| 514 | my $upstream = $m->{UPSTREAM} // 'undef'; |
| 515 | next if @$wanted_upstreams and !$wanted_upstream{$upstream}; |
| 516 | |
| 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"; |
| 529 | print $outfh " Perl: $pdist\n"; |
| 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 | } |
| 539 | } |
| 540 | } |
| 541 | |
| 542 | # get the EXCLUDED and MAP entries for this module, or |
| 543 | # make up defaults if they don't exist |
| 544 | |
| 545 | sub get_map { |
| 546 | my ( $m, $module_name, $perl_files ) = @_; |
| 547 | |
| 548 | my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)}; |
| 549 | |
| 550 | $excluded ||= []; |
| 551 | $customized ||= []; |
| 552 | |
| 553 | return $excluded, $map, $customized if $map; |
| 554 | |
| 555 | # all files under ext/foo-bar (plus maybe some under t/lib)??? |
| 556 | |
| 557 | my $ext; |
| 558 | for (@$perl_files) { |
| 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 | } |
| 575 | } |
| 576 | |
| 577 | if ( defined $ext ) { |
| 578 | $map = { '' => $ext },; |
| 579 | } |
| 580 | else { |
| 581 | ( my $base = $module_name ) =~ s{::}{/}g; |
| 582 | $base = "lib/$base"; |
| 583 | $map = { |
| 584 | 'lib/' => 'lib/', |
| 585 | '' => "$base/", |
| 586 | }; |
| 587 | } |
| 588 | return $excluded, $map, $customized; |
| 589 | } |
| 590 | |
| 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 | |
| 595 | sub cpan_to_perl { |
| 596 | my ( $excluded, $map, $customized, $cpan_file ) = @_; |
| 597 | |
| 598 | my %customized = map { ( $_ => 1 ) } @$customized; |
| 599 | for my $exclude (@$excluded) { |
| 600 | next if $customized{$exclude}; |
| 601 | |
| 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 | } |
| 609 | } |
| 610 | |
| 611 | my $perl_file = $cpan_file; |
| 612 | |
| 613 | # try longest prefix first, then alphabetically on tie-break |
| 614 | for |
| 615 | my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map ) |
| 616 | { |
| 617 | last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/; |
| 618 | } |
| 619 | return $perl_file; |
| 620 | } |
| 621 | |
| 622 | # fetch a file from a URL and store it in a file given by a filename |
| 623 | |
| 624 | sub my_getstore { |
| 625 | my ( $url, $file ) = @_; |
| 626 | File::Path::mkpath( File::Basename::dirname($file) ); |
| 627 | if ( $url =~ qr{\Afile://(?:localhost)?/} ) { |
| 628 | ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{}; |
| 629 | File::Copy::copy( $local_path, $file ); |
| 630 | } else { |
| 631 | my $http = HTTP::Tiny->new; |
| 632 | my $response = $http->mirror($url, $file); |
| 633 | return $response->{success}; |
| 634 | } |
| 635 | } |
| 636 | |
| 637 | # download and unpack a distribution |
| 638 | # Returns the full pathname of the extracted directory |
| 639 | # (eg '/tmp/XYZ/Foo_bar-1.23') |
| 640 | |
| 641 | # cache_dir: where to download the .tar.gz file to |
| 642 | # mirror_url: CPAN mirror to download from |
| 643 | # untar_dir: where to untar or unzup the file |
| 644 | # module: name of module |
| 645 | # dist: name of the distribution |
| 646 | |
| 647 | sub get_distribution { |
| 648 | my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_; |
| 649 | |
| 650 | $dist =~ m{.+/([^/]+)$} |
| 651 | or die |
| 652 | "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n"; |
| 653 | my $filename = $1; |
| 654 | |
| 655 | my $download_file = catfile( $src_dir, $filename ); |
| 656 | |
| 657 | # download distribution |
| 658 | |
| 659 | if ( -f $download_file and !-s $download_file ) { |
| 660 | |
| 661 | # failed download might leave a zero-length file |
| 662 | unlink $download_file; |
| 663 | } |
| 664 | |
| 665 | unless ( -f $download_file ) { |
| 666 | |
| 667 | # not cached |
| 668 | my $url = cpan_url_distribution( $mirror_url, $dist ); |
| 669 | my_getstore( $url, $download_file ) |
| 670 | or die "ERROR: Could not fetch '$url'\n"; |
| 671 | } |
| 672 | |
| 673 | # get the expected name of the extracted distribution dir |
| 674 | |
| 675 | my $path = catfile( $untar_dir, $filename ); |
| 676 | |
| 677 | $path =~ s/\.tar\.gz$// |
| 678 | or $path =~ s/\.tgz$// |
| 679 | or $path =~ s/\.zip$// |
| 680 | or die |
| 681 | "ERROR: downloaded file does not have a recognised suffix: $path\n"; |
| 682 | |
| 683 | # extract it unless we already have it cached or tarball is newer |
| 684 | if ( !-d $path || ( -M $download_file < -M $path ) ) { |
| 685 | $path = extract( $download_file, $untar_dir ) |
| 686 | or die |
| 687 | "ERROR: failed to extract distribution '$download_file to temp. dir: " |
| 688 | . $! . "\n"; |
| 689 | } |
| 690 | |
| 691 | die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path; |
| 692 | |
| 693 | return $path; |
| 694 | } |
| 695 | |
| 696 | # produce the diff of a single file |
| 697 | sub 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 | |
| 704 | my @cmd = ( DIFF_CMD, split ' ', $diff_opts ); |
| 705 | if ($reverse) { |
| 706 | push @cmd, $perl_file, $cpan_file; |
| 707 | } |
| 708 | else { |
| 709 | push @cmd, $cpan_file, $perl_file; |
| 710 | } |
| 711 | return `@cmd`; |
| 712 | |
| 713 | } |
| 714 | |
| 715 | sub customized { |
| 716 | my ( $module_data, $file ) = @_; |
| 717 | return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} }; |
| 718 | } |
| 719 | |
| 720 | sub 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 | |
| 745 | sub __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 | |
| 785 | run(); |
| 786 | |