Porting/sync-with-cpan

   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 Updates the contents of 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 OPTIONS
  94
  95 =over 4
  96
  97 =item C<--jobs> I<N>
  98
  99 When running C<make>, pass a C<< -jI<N> >> option to it.
 100
 101 =back
 102
 103 =head1 TODO
 104
 105 =over 4
 106
 107 =item *
 108
 109 Update F<Porting/Maintainers.pl>
 110
 111 =item *
 112
 113 Optional, run a full test suite
 114
 115 =item *
 116
 117 Handle complicated C<FILES>
 118
 119 =back
 120
 121 This is an initial version; no attempt has been made yet to make this
 122 portable. It shells out instead of trying to find a Perl solution.
 123 In particular, it assumes git, perl, and make
 124 to be available.
 125
 126 =cut
 127
 128
 129 package Maintainers;
 130
 131 use 5.010;
 132
 133 use strict;
 134 use warnings;
 135 use Getopt::Long;
 136 use Archive::Tar;
 137 use File::Basename qw( basename );
 138 use File::Path qw( remove_tree );
 139 use File::Find;
 140 use File::Spec::Functions qw( tmpdir );
 141 use Config qw( %Config );
 142
 143 $| = 1;
 144
 145 use constant WIN32 => $^O eq 'MSWin32';
 146
 147 die "This does not look like a top level directory"
 148      unless -d "cpan" && -d "Porting";
 149
 150 # Check that there's a Makefile, if needed; otherwise, we'll do most of our
 151 # work only to fail when we try to run make, and the user will have to
 152 # either unpick everything we've done, or do the rest manually.
 153 die "Please run Configure before using $0\n"
 154     if !WIN32 && !-f "Makefile";
 155
 156 our @IGNORABLE;
 157 our %Modules;
 158
 159 use autodie;
 160
 161 require "Porting/Maintainers.pl";
 162
 163 my $MAKE_LOG = 'make.log';
 164
 165 my %IGNORABLE    = map {$_ => 1} @IGNORABLE;
 166
 167 my $tmpdir = tmpdir();
 168
 169 my $package      = "02packages.details.txt";
 170 my $package_url  = "http://www.cpan.org/modules/$package";
 171 my $package_file = "$tmpdir/$package"; # this is a cache
 172
 173 my @problematic = (
 174     'podlators', # weird CUSTOMIZED section due to .PL files
 175 );
 176
 177
 178 sub usage
 179 {
 180     my $err = shift and select STDERR;
 181     print "Usage: $0 module [args] [cpan package]\n";
 182     exit $err;
 183 }
 184
 185 GetOptions ('tarball=s'  =>  \my $tarball,
 186             'version=s'  =>  \my $version,
 187             'jobs=i'     =>  \my $make_jobs,
 188              force       =>  \my $force,
 189              help        =>  sub { usage 0; },
 190              ) or  die "Failed to parse arguments";
 191
 192 usage 1 unless @ARGV == 1 || @ARGV == 2;
 193
 194 sub find_type_f {
 195     my @res;
 196     find( { no_chdir => 1, wanted => sub {
 197         my $file= $File::Find::name;
 198         return unless -f $file;
 199         push @res, $file
 200     }}, @_ );
 201     @res
 202 };
 203
 204 # Equivalent of `chmod a-x`
 205 sub de_exec {
 206     my ($filename) = @_;
 207     my $mode = (stat $filename)[2] & 0777;
 208     if ($mode & 0111) { # exec-bit set
 209         chmod $mode & 0666, $filename;
 210     }
 211 }
 212
 213 # Equivalent of `chmod +w`
 214 sub make_writable {
 215     my ($filename) = @_;
 216     my $mode = (stat $filename)[2] & 0777;
 217     if (!($mode & 0222)) { # not writable
 218         chmod $mode | (0222 & ~umask), $filename;
 219     }
 220 }
 221
 222 sub make {
 223     my @args= @_;
 224     unshift @args, "-j$make_jobs" if defined $make_jobs;
 225     if (WIN32) {
 226         chdir "Win32";
 227         system "$Config{make} @args> ..\\$MAKE_LOG 2>&1"
 228             and die "Running make failed, see $MAKE_LOG";
 229         chdir '..';
 230     } else {
 231         system "$Config{make} @args> $MAKE_LOG 2>&1"
 232             and die "Running make failed, see $MAKE_LOG";
 233     };
 234 };
 235
 236 my ($module)  = shift;
 237
 238 my $info = $Modules{$module};
 239 if (!$info) {
 240     # Maybe the user said "Test-Simple" instead of "Test::Simple", or
 241     # "IO::Compress" instead of "IO-Compress". See if we can fix it up.
 242     my $guess = $module;
 243     s/-/::/g or s/::/-/g for $guess;
 244     $info = $Modules{$guess} or die <<"EOF";
 245 Cannot find module $module.
 246 The available options are listed in the %Modules hash in Porting/Maintainers.pl
 247 EOF
 248     say "Guessing you meant $guess instead of $module";
 249     $module = $guess;
 250 }
 251
 252 if ($info->{CUSTOMIZED}) {
 253     print <<"EOF";
 254 $module has a CUSTOMIZED entry in Porting/Maintainers.pl.
 255
 256 This program's behaviour is to copy every CUSTOMIZED file into the version
 257 of the module being imported. But that might not be the right thing: in some
 258 cases, the new CPAN version will supersede whatever changes had previously
 259 been made in blead, so it would be better to import the new CPAN files.
 260
 261 If you've checked that the CUSTOMIZED versions are still correct, you can
 262 proceed now. Otherwise, you should abort and investigate the situation. If
 263 the blead customizations are no longer needed, delete the CUSTOMIZED entry
 264 for $module in Porting/Maintainers.pl (and you'll also need to regenerate
 265 t/porting/customized.dat in that case; see t/porting/customized.t).
 266
 267 EOF
 268     print "Hit return to continue; ^C to abort "; <STDIN>;
 269 }
 270
 271 my $cpan_mod = @ARGV ? shift : $module;
 272
 273 my  $distribution = $$info {DISTRIBUTION};
 274
 275 my @files         = glob $$info {FILES};
 276 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
 277     say "This looks like a setup $0 cannot handle (yet)";
 278     unless ($force) {
 279         say "Will not continue without a --force option";
 280         exit 1;
 281     }
 282     say "--force is in effect, so we'll soldier on. Wish me luck!";
 283 }
 284
 285
 286 chdir "cpan";
 287
 288 my  $pkg_dir      = $files[0];
 289     $pkg_dir      =~ s!.*/!!;
 290
 291 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
 292
 293 my  $o_module     = $module;
 294 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
 295     $cpan_mod =~ s/-/::/g;
 296 }
 297
 298 #
 299 # Find the information from CPAN.
 300 #
 301 my $new_file;
 302 my $new_version;
 303 if (defined $tarball) {
 304     die "Tarball $tarball does not exist\n" if !-e $tarball;
 305     die "Tarball $tarball is not a plain file\n" if !-f _;
 306     $new_file     = $tarball;
 307     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
 308     die "Blead and that tarball both have version $new_version of $module\n"
 309         if $new_version eq $old_version;
 310 }
 311 else {
 312     #
 313     # Poor man's cache
 314     #
 315     unless (-f $package_file && -M $package_file < 1) {
 316         eval {
 317             require HTTP::Tiny;
 318             my $http= HTTP::Tiny->new();
 319             $http->mirror( $package_url => $package_file );
 320             1
 321         } or system wget => $package_url, '-qO', $package_file;
 322     }
 323
 324     open my $fh, '<', $package_file;
 325     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
 326                      or die "Cannot find $cpan_mod on CPAN\n";
 327     (undef, $new_version, my $new_path) = split ' ', $new_line;
 328     if (defined $version) {
 329         $new_path =~ s/-$new_version\./-$version\./;
 330         $new_version = $version;
 331     }
 332     $new_file = (split '/', $new_path) [-1];
 333
 334     die "The latest version of $module is $new_version, but blead already has it\n"
 335         if $new_version eq $old_version;
 336
 337     my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
 338     say "Fetching $url";
 339     #
 340     # Fetch the new distro
 341     #
 342     eval {
 343         require HTTP::Tiny;
 344         my $http= HTTP::Tiny->new();
 345         $http->mirror( $url => $new_file );
 346         1
 347     } or system wget => $url, '-qO', $new_file;
 348 }
 349
 350 my  $old_dir      = "$pkg_dir-$old_version";
 351
 352 say "Cleaning out old directory";
 353 system git => 'clean', '-dfxq', $pkg_dir;
 354
 355 say "Unpacking $new_file";
 356 Archive::Tar->extract_archive( $new_file );
 357
 358 (my $new_dir = basename($new_file)) =~ s/\.tar\.gz//;
 359 # ensure 'make' will update all files
 360 my $t= time;
 361 for my $file (find_type_f($new_dir)) {
 362     make_writable($file); # for convenience if the user later edits it
 363     utime($t,$t,$file);
 364 };
 365
 366 say "Renaming directories";
 367 rename $pkg_dir => $old_dir;
 368
 369 say "Creating new package directory";
 370 mkdir $pkg_dir;
 371
 372 say "Populating new package directory";
 373 my $map = $$info {MAP};
 374 my @EXCLUDED_QR;
 375 my %EXCLUDED_QQ;
 376 if ($$info {EXCLUDED}) {
 377     foreach my $entry (@{$$info {EXCLUDED}}) {
 378         if (ref $entry) {push @EXCLUDED_QR => $entry}
 379         else            {$EXCLUDED_QQ {$entry} = 1}
 380     }
 381 }
 382
 383 FILE: for my $file ( find_type_f( $new_dir )) {
 384     my $old_file = $file;
 385     $file =~ s{^$new_dir/}{};
 386
 387     next if $EXCLUDED_QQ{$file};
 388     for my $qr (@EXCLUDED_QR) {
 389         next FILE if $file =~ $qr;
 390     }
 391
 392     if ( $map ) {
 393         for my $key ( sort { length $b <=> length $a } keys %$map ) {
 394             my $val = $map->{$key};
 395             last if $file =~ s/^$key/$val/;
 396         }
 397     }
 398     else {
 399         $file = $files[0] . '/' . $file;
 400     }
 401
 402     if ( $file =~ m{^cpan/} ) {
 403         $file =~ s{^cpan/}{};
 404     }
 405     else {
 406         $file = '../' . $file;
 407     }
 408
 409     my $prefix = '';
 410     my @parts = split '/', $file;
 411     pop @parts;
 412     for my $part (@parts) {
 413         $prefix .= '/' if $prefix;
 414         $prefix .= $part;
 415         mkdir $prefix unless -d $prefix;
 416     }
 417
 418     rename $old_file => $file;
 419 }
 420 remove_tree( $new_dir );
 421
 422 if (-f "$old_dir/.gitignore") {
 423     say "Restoring .gitignore";
 424     system git => 'checkout', "$pkg_dir/.gitignore";
 425 }
 426
 427 my @new_files = find_type_f( $pkg_dir );
 428 @new_files = grep {$_ ne $pkg_dir} @new_files;
 429 s!^[^/]+/!! for @new_files;
 430 my %new_files = map {$_ => 1} @new_files;
 431
 432 my @old_files = find_type_f( $old_dir );
 433 @old_files = grep {$_ ne $old_dir} @old_files;
 434 s!^[^/]+/!! for @old_files;
 435 my %old_files = map {$_ => 1} @old_files;
 436
 437 my @delete;
 438 my @commit;
 439 my @gone;
 440 FILE:
 441 foreach my $file (@new_files) {
 442     next if -d "$pkg_dir/$file";   # Ignore directories.
 443     next if $old_files {$file};    # It's already there.
 444     if ($IGNORABLE {$file}) {
 445         push @delete => $file;
 446         next;
 447     }
 448     push @commit => $file;
 449 }
 450 foreach my $file (@old_files) {
 451     next if -d "$old_dir/$file";
 452     next if $new_files {$file};
 453     push @gone => $file;
 454 }
 455
 456 #
 457 # Find all files with an exec bit
 458 #
 459 my @exec = find_type_f( $pkg_dir );
 460 my @de_exec;
 461 foreach my $file (@exec) {
 462     # Remove leading dir
 463     $file =~ s!^[^/]+/!!;
 464     if ($file =~ m!^t/!) {
 465         push @de_exec => $file;
 466         next;
 467     }
 468     # Check to see if the file exists; if it doesn't and doesn't have
 469     # the exec bit, remove it.
 470     if ($old_files {$file}) {
 471         unless (-x "$old_dir/$file") {
 472             push @de_exec => $file;
 473         }
 474     }
 475 }
 476
 477 #
 478 # No need to change the +x bit on files that will be deleted.
 479 #
 480 if (@de_exec && @delete) {
 481     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
 482     @de_exec = grep {!$delete {$_}} @de_exec;
 483 }
 484
 485 say "unlink $pkg_dir/$_" for @delete;
 486 say "git add $pkg_dir/$_" for @commit;
 487 say "git rm -f $pkg_dir/$_" for @gone;
 488 say "chmod a-x $pkg_dir/$_" for @de_exec;
 489
 490 print "Hit return to continue; ^C to abort "; <STDIN>;
 491
 492 unlink "$pkg_dir/$_"                      for @delete;
 493 system git   => 'add', "$pkg_dir/$_"      for @commit;
 494 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
 495 de_exec( "$pkg_dir/$_" )                  for @de_exec;
 496
 497 #
 498 # Restore anything that is customized.
 499 # We don't really care whether we've deleted the file - since we
 500 # do a git restore, it's going to be resurrected if necessary.
 501 #
 502 if ($$info {CUSTOMIZED}) {
 503     say "Restoring customized files";
 504     foreach my $file (@{$$info {CUSTOMIZED}}) {
 505         system git => "checkout", "$pkg_dir/$file";
 506     }
 507 }
 508
 509 chdir "..";
 510 if (@commit || @gone) {
 511     say "Fixing MANIFEST";
 512     my $MANIFEST     = "MANIFEST";
 513     my $MANIFEST_NEW = "$MANIFEST.new";
 514
 515     open my $orig, "<", $MANIFEST
 516         or die "Failed to open $MANIFEST for reading: $!\n";
 517     open my $new, ">", $MANIFEST_NEW
 518         or die "Failed to open $MANIFEST_NEW for writing: $!\n";
 519     my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
 520     while (my $line = <$orig>) {
 521         my ($file) = $line =~ /^(\S+)/
 522             or die "Can't parse MANIFEST line: $line";
 523         print $new $line if !$gone{$file};
 524     }
 525
 526     say $new "cpan/$pkg_dir/$_" for @commit;
 527
 528     close $new or die "Can't close $MANIFEST: $!\n";
 529
 530     system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
 531     unlink $MANIFEST_NEW
 532         or die "Can't delete temporary $MANIFEST_NEW: $!\n";
 533 }
 534
 535
 536 print "Running a make and saving its output to $MAKE_LOG ... ";
 537 # Prepare for running (selected) tests
 538 make 'test-prep';
 539 print "done\n";
 540
 541 # The build system installs code from CPAN dists into the lib/ directory,
 542 # creating directories as needed. This means that the cleaning-related rules
 543 # in the Makefile need to know which directories to clean up. The Makefile
 544 # is generated by Configure from Makefile.SH, so *that* file needs the list
 545 # of directories. regen/lib_cleanup.pl is capable of automatically updating
 546 # the contents of Makefile.SH (and win32/Makefile, which needs similar but
 547 # not identical lists of directories), so we can just run that (using the
 548 # newly-built Perl, as is done with the regen programs run by "make regen").
 549 #
 550 # We do this if any files at all have been added or deleted, regardless of
 551 # whether those changes result in any directories being added or deleted,
 552 # because the alternative would be to replicate the regen/lib_cleanup.pl
 553 # logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
 554 # repeatedly.
 555 if (@commit || @gone) {
 556     say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
 557     my $exe_dir = WIN32 ? ".\\" : './';
 558     system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
 559         and die "regen/lib_cleanup.pl failed\n";
 560 }
 561
 562 #
 563 # Must clean up, or else t/porting/FindExt.t will fail.
 564 # Note that we can always retrieve the original directory with a git checkout.
 565 #
 566 print "About to clean up; hit return or abort (^C) "; <STDIN>;
 567
 568 remove_tree( "cpan/$old_dir" );
 569 unlink "cpan/$new_file" unless $tarball;
 570
 571 #
 572 # Run the tests. First the test belonging to the module, followed by the
 573 # the tests in t/porting
 574 #
 575 chdir "t";
 576 say "Running module tests";
 577 my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
 578 my $exe_dir = WIN32 ? "..\\" : './';
 579 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
 580 unless ($output =~ /All tests successful/) {
 581     say $output;
 582     exit 1;
 583 }
 584
 585 print "Running tests in t/porting ";
 586 my @tests = glob 'porting/*.t';
 587 chomp @tests;
 588 my @failed;
 589 foreach my $t (@tests) {
 590     my @not = grep {!/# TODO/ }
 591               grep { /^not/ }
 592               `${exe_dir}perl -I../lib -I.. $t`;
 593     print @not ? '!' : '.';
 594     push @failed => $t if @not;
 595 }
 596 print "\n";
 597 say "Failed tests: @failed" if @failed;
 598
 599
 600 chdir '..';
 601
 602 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
 603 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
 604
 605 my $found;
 606 my $in_mod_section;
 607 while (<$Maintainers_pl>) {
 608     if (!$found) {
 609         if ($in_mod_section) {
 610             if (/DISTRIBUTION/) {
 611                 if (s/\Q$old_version/$new_version/) {
 612                     $found = 1;
 613                 }
 614             }
 615
 616             if (/^    \}/) {
 617                 $in_mod_section = 0;
 618             }
 619         }
 620
 621         if (/\Q$module/) {
 622             $in_mod_section = 1;
 623         }
 624     }
 625
 626     print $new_Maintainers_pl $_;
 627 }
 628
 629 if ($found) {
 630     say "Successfully updated Maintainers.pl";
 631     unlink 'Porting/Maintainers.pl';
 632     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
 633     chmod 0755 => 'Porting/Maintainers.pl';
 634 }
 635 else {
 636     say "Could not update Porting/Maintainers.pl.";
 637     say "Make sure you update this by hand before committing.";
 638 }
 639
 640 print <<"EOF";
 641
 642 =======================================================================
 643
 644 $o_module is now at version $new_version
 645 Next, you should run a "make test".
 646
 647 Hopefully that will complete successfully, but if not, you can make any
 648 changes you need to get the tests to pass. Don't forget that you'll need
 649 a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
 650 files under cpan/$pkg_dir.
 651
 652 Once all tests pass, you can "git add -u" and "git commit" the changes.
 653
 654 EOF
 655
 656 __END__