| 1 | #!/usr/bin/env perl |
| 2 | |
| 3 | =head1 NAME |
| 4 | |
| 5 | Porting/sync-with-cpan - Synchronize with CPAN distributions |
| 6 | |
| 7 | =head1 SYNOPSIS |
| 8 | |
| 9 | perl Porting/sync-with-cpan <module> |
| 10 | |
| 11 | where <module> is the name it appears in the C<%Modules> hash |
| 12 | of F<Porting/Maintainers.pl> |
| 13 | |
| 14 | =head1 DESCRIPTION |
| 15 | |
| 16 | Script to help out with syncing cpan distros. |
| 17 | |
| 18 | Does the following: |
| 19 | |
| 20 | =over 4 |
| 21 | |
| 22 | =item * |
| 23 | |
| 24 | Fetches the package list from CPAN. Finds the current version of the given |
| 25 | package. [1] |
| 26 | |
| 27 | =item * |
| 28 | |
| 29 | Downloads the relevant tarball; unpacks the tarball. [1] |
| 30 | |
| 31 | =item * |
| 32 | |
| 33 | Clean out the old directory (C<git clean -dfx>) |
| 34 | |
| 35 | =item * |
| 36 | |
| 37 | Moves the old directory out of the way, moves the new directory in place. |
| 38 | |
| 39 | =item * |
| 40 | |
| 41 | Restores any F<.gitignore> file. |
| 42 | |
| 43 | =item * |
| 44 | |
| 45 | Removes files from C<@IGNORE> and C<EXCLUDED> |
| 46 | |
| 47 | =item * |
| 48 | |
| 49 | C<git add> any new files. |
| 50 | |
| 51 | =item * |
| 52 | |
| 53 | C<git rm> any files that are gone. |
| 54 | |
| 55 | =item * |
| 56 | |
| 57 | Remove the +x bit on files in F<t/> |
| 58 | |
| 59 | =item * |
| 60 | |
| 61 | Remove the +x bit on files that don't have it enabled in the current dir |
| 62 | |
| 63 | =item * |
| 64 | |
| 65 | Restore files mentioned in C<CUSTOMIZED> |
| 66 | |
| 67 | =item * |
| 68 | |
| 69 | Adds new files to F<MANIFEST> |
| 70 | |
| 71 | =item * |
| 72 | |
| 73 | Runs a C<make> (assumes a configure has been run) |
| 74 | |
| 75 | =item * |
| 76 | |
| 77 | Cleans up |
| 78 | |
| 79 | =item * |
| 80 | |
| 81 | Runs tests for the package |
| 82 | |
| 83 | =item * |
| 84 | |
| 85 | Runs the porting tests |
| 86 | |
| 87 | =back |
| 88 | |
| 89 | [1] If the C<--tarball> option is given, then CPAN is not consulted. |
| 90 | C<--tarball> should be the path to the tarball; the version is extracted |
| 91 | from the filename -- but can be overwritten by the C<--version> option. |
| 92 | |
| 93 | =head1 TODO |
| 94 | |
| 95 | =over 4 |
| 96 | |
| 97 | =item * |
| 98 | |
| 99 | Delete files from F<MANIFEST> |
| 100 | |
| 101 | =item * |
| 102 | |
| 103 | Update F<Porting/Maintainers.pl> |
| 104 | |
| 105 | =item * |
| 106 | |
| 107 | Optional, run a full test suite |
| 108 | |
| 109 | =item * |
| 110 | |
| 111 | Handle complicated C<FILES> |
| 112 | |
| 113 | =back |
| 114 | |
| 115 | This is an initial version; no attempt has been made yet to make this |
| 116 | portable. It shells out instead of trying to find a Perl solution. |
| 117 | In particular, it assumes wget, git, tar, chmod, perl, make, and rm |
| 118 | to be available. |
| 119 | |
| 120 | =cut |
| 121 | |
| 122 | |
| 123 | package Maintainers; |
| 124 | |
| 125 | use 5.010; |
| 126 | |
| 127 | use strict; |
| 128 | use warnings; |
| 129 | use Getopt::Long; |
| 130 | use Archive::Tar; |
| 131 | |
| 132 | $| = 1; |
| 133 | |
| 134 | die "This does not look like a top level directory" |
| 135 | unless -d "cpan" && -d "Porting"; |
| 136 | |
| 137 | our @IGNORABLE; |
| 138 | our %Modules; |
| 139 | |
| 140 | use autodie; |
| 141 | |
| 142 | require "Porting/Maintainers.pl"; |
| 143 | |
| 144 | my %IGNORABLE = map {$_ => 1} @IGNORABLE; |
| 145 | |
| 146 | my $package = "02packages.details.txt"; |
| 147 | my $package_url = "http://www.cpan.org/modules/$package"; |
| 148 | my $package_file = "/tmp/$package"; |
| 149 | |
| 150 | my @problematic = ( |
| 151 | 'podlators', # weird CUSTOMIZED section due to .PL files |
| 152 | ); |
| 153 | |
| 154 | |
| 155 | GetOptions ('tarball=s' => \my $tarball, |
| 156 | 'version=s' => \my $version, |
| 157 | force => \my $force,) |
| 158 | or die "Failed to parse arguments"; |
| 159 | |
| 160 | die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2; |
| 161 | |
| 162 | my ($module) = shift; |
| 163 | my $cpan_mod = @ARGV ? shift : $module; |
| 164 | |
| 165 | |
| 166 | my $info = $Modules {$module} or die "Cannot find module $module"; |
| 167 | my $distribution = $$info {DISTRIBUTION}; |
| 168 | |
| 169 | my @files = glob $$info {FILES}; |
| 170 | if (!-d $files [0] || grep { $_ eq $module } @problematic) { |
| 171 | say "This looks like a setup $0 cannot handle (yet)"; |
| 172 | unless ($force) { |
| 173 | say "Will not continue without a --force option"; |
| 174 | exit 1; |
| 175 | } |
| 176 | say "--force is in effect, so we'll soldier on. Wish me luck!"; |
| 177 | } |
| 178 | |
| 179 | |
| 180 | chdir "cpan"; |
| 181 | |
| 182 | my $pkg_dir = $files[0]; |
| 183 | $pkg_dir =~ s!.*/!!; |
| 184 | |
| 185 | my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/; |
| 186 | |
| 187 | my $o_module = $module; |
| 188 | if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) { |
| 189 | $cpan_mod =~ s/-/::/g; |
| 190 | } |
| 191 | |
| 192 | # |
| 193 | # Find the information from CPAN. |
| 194 | # |
| 195 | my $new_file; |
| 196 | my $new_version; |
| 197 | unless ($tarball) { |
| 198 | # |
| 199 | # Poor man's cache |
| 200 | # |
| 201 | unless (-f $package_file && -M $package_file < 1) { |
| 202 | system wget => $package_url, '-qO', $package_file; |
| 203 | } |
| 204 | |
| 205 | my $new_line = `grep '^$cpan_mod ' $package_file` |
| 206 | or die "Cannot find $cpan_mod on CPAN\n"; |
| 207 | chomp $new_line; |
| 208 | (undef, $new_version, my $new_path) = split ' ', $new_line; |
| 209 | if (defined $version) { |
| 210 | $new_path =~ s/-$new_version\./-$version\./; |
| 211 | $new_version = $version; |
| 212 | } |
| 213 | $new_file = (split '/', $new_path) [-1]; |
| 214 | |
| 215 | my $url = "http://search.cpan.org/CPAN/authors/id/$new_path"; |
| 216 | say "Fetching $url"; |
| 217 | # |
| 218 | # Fetch the new distro |
| 219 | # |
| 220 | system wget => $url, '-qO', $new_file; |
| 221 | } |
| 222 | else { |
| 223 | $new_file = $tarball; |
| 224 | $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0]; |
| 225 | } |
| 226 | |
| 227 | my $old_dir = "$pkg_dir-$old_version"; |
| 228 | |
| 229 | say "Cleaning out old directory"; |
| 230 | system git => 'clean', '-dfxq', $pkg_dir; |
| 231 | |
| 232 | say "Unpacking $new_file"; |
| 233 | Archive::Tar->extract_archive( $new_file ); |
| 234 | |
| 235 | (my $new_dir = $new_file) =~ s/\.tar\.gz//; |
| 236 | # ensure 'make' will update all files |
| 237 | system('find', $new_dir, '-exec', 'touch', '{}', ';'); |
| 238 | |
| 239 | say "Renaming directories"; |
| 240 | rename $pkg_dir => $old_dir; |
| 241 | |
| 242 | say "Creating new package directory"; |
| 243 | mkdir $pkg_dir; |
| 244 | |
| 245 | say "Populating new package directory"; |
| 246 | my $map = $$info {MAP}; |
| 247 | my @EXCLUDED_QR; |
| 248 | my %EXCLUDED_QQ; |
| 249 | if ($$info {EXCLUDED}) { |
| 250 | foreach my $entry (@{$$info {EXCLUDED}}) { |
| 251 | if (ref $entry) {push @EXCLUDED_QR => $entry} |
| 252 | else {$EXCLUDED_QQ {$entry} = 1} |
| 253 | } |
| 254 | } |
| 255 | |
| 256 | FILE: for my $file ( `find $new_dir -type f` ) { |
| 257 | chomp $file; |
| 258 | my $old_file = $file; |
| 259 | $file =~ s{^$new_dir/}{}; |
| 260 | |
| 261 | next if $EXCLUDED_QQ{$file}; |
| 262 | for my $qr (@EXCLUDED_QR) { |
| 263 | next FILE if $file =~ $qr; |
| 264 | } |
| 265 | |
| 266 | if ( $map ) { |
| 267 | for my $key ( sort { length $b <=> length $a } keys %$map ) { |
| 268 | my $val = $map->{$key}; |
| 269 | last if $file =~ s/^$key/$val/; |
| 270 | } |
| 271 | } |
| 272 | else { |
| 273 | $file = $files[0] . '/' . $file; |
| 274 | } |
| 275 | |
| 276 | if ( $file =~ m{^cpan/} ) { |
| 277 | $file =~ s{^cpan/}{}; |
| 278 | } |
| 279 | else { |
| 280 | $file = '../' . $file; |
| 281 | } |
| 282 | |
| 283 | my $prefix = ''; |
| 284 | my @parts = split '/', $file; |
| 285 | pop @parts; |
| 286 | for my $part (@parts) { |
| 287 | $prefix .= '/' if $prefix; |
| 288 | $prefix .= $part; |
| 289 | mkdir $prefix unless -d $prefix; |
| 290 | } |
| 291 | |
| 292 | rename $old_file => $file; |
| 293 | } |
| 294 | system 'rm', '-rf', $new_dir; |
| 295 | |
| 296 | if (-f "$old_dir/.gitignore") { |
| 297 | say "Restoring .gitignore"; |
| 298 | system git => 'checkout', "$pkg_dir/.gitignore"; |
| 299 | } |
| 300 | |
| 301 | my @new_files = `find $pkg_dir -type f`; |
| 302 | chomp @new_files; |
| 303 | @new_files = grep {$_ ne $pkg_dir} @new_files; |
| 304 | s!^[^/]+/!! for @new_files; |
| 305 | my %new_files = map {$_ => 1} @new_files; |
| 306 | |
| 307 | my @old_files = `find $old_dir -type f`; |
| 308 | chomp @old_files; |
| 309 | @old_files = grep {$_ ne $old_dir} @old_files; |
| 310 | s!^[^/]+/!! for @old_files; |
| 311 | my %old_files = map {$_ => 1} @old_files; |
| 312 | |
| 313 | my @delete; |
| 314 | my @commit; |
| 315 | my @gone; |
| 316 | FILE: |
| 317 | foreach my $file (@new_files) { |
| 318 | next if -d "$pkg_dir/$file"; # Ignore directories. |
| 319 | next if $old_files {$file}; # It's already there. |
| 320 | if ($IGNORABLE {$file}) { |
| 321 | push @delete => $file; |
| 322 | next; |
| 323 | } |
| 324 | push @commit => $file; |
| 325 | } |
| 326 | foreach my $file (@old_files) { |
| 327 | next if -d "$old_dir/$file"; |
| 328 | next if $new_files {$file}; |
| 329 | push @gone => $file; |
| 330 | } |
| 331 | |
| 332 | # |
| 333 | # Find all files with an exec bit |
| 334 | # |
| 335 | my @exec = `find $pkg_dir -type f -perm +111`; |
| 336 | chomp @exec; |
| 337 | my @de_exec; |
| 338 | foreach my $file (@exec) { |
| 339 | # Remove leading dir |
| 340 | $file =~ s!^[^/]+/!!; |
| 341 | if ($file =~ m!^t/!) { |
| 342 | push @de_exec => $file; |
| 343 | next; |
| 344 | } |
| 345 | # Check to see if the file exists; if it doesn't and doesn't have |
| 346 | # the exec bit, remove it. |
| 347 | if ($old_files {$file}) { |
| 348 | unless (-x "$old_dir/$file") { |
| 349 | push @de_exec => $file; |
| 350 | } |
| 351 | } |
| 352 | } |
| 353 | |
| 354 | # |
| 355 | # No need to change the +x bit on files that will be deleted. |
| 356 | # |
| 357 | if (@de_exec && @delete) { |
| 358 | my %delete = map {+"$pkg_dir/$_" => 1} @delete; |
| 359 | @de_exec = grep {!$delete {$_}} @de_exec; |
| 360 | } |
| 361 | |
| 362 | say "unlink $pkg_dir/$_" for @delete; |
| 363 | say "git add $pkg_dir/$_" for @commit; |
| 364 | say "git rm -f $pkg_dir/$_" for @gone; |
| 365 | say "chmod a-x $pkg_dir/$_" for @de_exec; |
| 366 | |
| 367 | print "Hit return to continue; ^C to abort "; <STDIN>; |
| 368 | |
| 369 | unlink "$pkg_dir/$_" for @delete; |
| 370 | system git => 'add', "$pkg_dir/$_" for @commit; |
| 371 | system git => 'rm', '-f', "$pkg_dir/$_" for @gone; |
| 372 | system chmod => 'a-x', "$pkg_dir/$_" for @de_exec; |
| 373 | |
| 374 | # |
| 375 | # Restore anything that is customized. |
| 376 | # We don't really care whether we've deleted the file - since we |
| 377 | # do a git restore, it's going to be resurrected if necessary. |
| 378 | # |
| 379 | if ($$info {CUSTOMIZED}) { |
| 380 | say "Restoring customized files"; |
| 381 | foreach my $file (@{$$info {CUSTOMIZED}}) { |
| 382 | system git => "checkout", "$pkg_dir/$file"; |
| 383 | } |
| 384 | } |
| 385 | |
| 386 | chdir ".."; |
| 387 | if (@commit) { |
| 388 | say "Fixing MANIFEST"; |
| 389 | my $MANIFEST = "MANIFEST"; |
| 390 | my $MANIFEST_SORT = "$MANIFEST.sorted"; |
| 391 | open my $fh, ">>", $MANIFEST; |
| 392 | say $fh "cpan/$pkg_dir/$_" for @commit; |
| 393 | close $fh; |
| 394 | system perl => "Porting/manisort", '--output', $MANIFEST_SORT; |
| 395 | rename $MANIFEST_SORT => $MANIFEST; |
| 396 | } |
| 397 | |
| 398 | |
| 399 | print "Running a make ... "; |
| 400 | system "make > make.log 2>&1" and die "Running make failed, see make.log"; |
| 401 | print "done\n"; |
| 402 | |
| 403 | # |
| 404 | # Must clean up, or else t/porting/FindExt.t will fail. |
| 405 | # Note that we can always retrieve the original directory with a git checkout. |
| 406 | # |
| 407 | print "About to clean up; hit return or abort (^C) "; <STDIN>; |
| 408 | |
| 409 | chdir "cpan"; |
| 410 | system rm => '-r', $old_dir; |
| 411 | unlink $new_file unless $tarball; |
| 412 | |
| 413 | |
| 414 | # |
| 415 | # Run the tests. First the test belonging to the module, followed by the |
| 416 | # the tests in t/porting |
| 417 | # |
| 418 | chdir "../t"; |
| 419 | say "Running module tests"; |
| 420 | my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`; |
| 421 | chomp @test_files; |
| 422 | my $output = `./perl TEST @test_files`; |
| 423 | unless ($output =~ /All tests successful/) { |
| 424 | say $output; |
| 425 | exit 1; |
| 426 | } |
| 427 | |
| 428 | print "Running tests in t/porting "; |
| 429 | my @tests = `ls porting/*.t`; |
| 430 | chomp @tests; |
| 431 | my @failed; |
| 432 | foreach my $t (@tests) { |
| 433 | my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`; |
| 434 | print @not ? '!' : '.'; |
| 435 | push @failed => $t if @not; |
| 436 | } |
| 437 | print "\n"; |
| 438 | say "Failed tests: @failed" if @failed; |
| 439 | |
| 440 | |
| 441 | say "Attempting to update Maintainers.pl"; |
| 442 | chdir '..'; |
| 443 | |
| 444 | open my $Maintainers_pl, '<', 'Porting/Maintainers.pl'; |
| 445 | open my $new_Maintainers_pl, '>', 'Maintainers.pl'; |
| 446 | |
| 447 | my $found; |
| 448 | my $in_mod_section; |
| 449 | while (<$Maintainers_pl>) { |
| 450 | if (!$found) { |
| 451 | if ($in_mod_section) { |
| 452 | if (/DISTRIBUTION/) { |
| 453 | if (s/\Q$old_version/$new_version/) { |
| 454 | $found = 1; |
| 455 | } |
| 456 | } |
| 457 | |
| 458 | if (/^ }/) { |
| 459 | $in_mod_section = 0; |
| 460 | } |
| 461 | } |
| 462 | |
| 463 | if (/\Q$cpan_mod/) { |
| 464 | $in_mod_section = 1; |
| 465 | } |
| 466 | } |
| 467 | |
| 468 | print $new_Maintainers_pl $_; |
| 469 | } |
| 470 | |
| 471 | if ($found) { |
| 472 | unlink 'Porting/Maintainers.pl'; |
| 473 | rename 'Maintainers.pl' => 'Porting/Maintainers.pl'; |
| 474 | system chmod => 'a+x', 'Porting/Maintainers.pl'; |
| 475 | } |
| 476 | else { |
| 477 | say "Could not update Porting/Maintainers.pl."; |
| 478 | say "Make sure you update this by hand before committing."; |
| 479 | } |
| 480 | |
| 481 | say "$o_module is now version $new_version"; |
| 482 | say "Now you ought to run a make; make test ..."; |
| 483 | |
| 484 | |
| 485 | __END__ |