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 #
 486 # Mustn't change the +x bit on files that are whitelisted
 487 #
 488 if (@de_exec) {
 489     my %permitted = map +(tr/\n//dr => 1), grep !/^#/,
 490         do { local @ARGV = '../Porting/exec-bit.txt'; <> };
 491     @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
 492 }
 493
 494 say "unlink $pkg_dir/$_" for @delete;
 495 say "git add $pkg_dir/$_" for @commit;
 496 say "git rm -f $pkg_dir/$_" for @gone;
 497 say "chmod a-x $pkg_dir/$_" for @de_exec;
 498
 499 print "Hit return to continue; ^C to abort "; <STDIN>;
 500
 501 unlink "$pkg_dir/$_"                      for @delete;
 502 system git   => 'add', "$pkg_dir/$_"      for @commit;
 503 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
 504 de_exec( "$pkg_dir/$_" )                  for @de_exec;
 505
 506 #
 507 # Restore anything that is customized.
 508 # We don't really care whether we've deleted the file - since we
 509 # do a git restore, it's going to be resurrected if necessary.
 510 #
 511 if ($$info {CUSTOMIZED}) {
 512     say "Restoring customized files";
 513     foreach my $file (@{$$info {CUSTOMIZED}}) {
 514         system git => "checkout", "$pkg_dir/$file";
 515     }
 516 }
 517
 518 chdir "..";
 519 if (@commit || @gone) {
 520     say "Fixing MANIFEST";
 521     my $MANIFEST     = "MANIFEST";
 522     my $MANIFEST_NEW = "$MANIFEST.new";
 523
 524     open my $orig, "<", $MANIFEST
 525         or die "Failed to open $MANIFEST for reading: $!\n";
 526     open my $new, ">", $MANIFEST_NEW
 527         or die "Failed to open $MANIFEST_NEW for writing: $!\n";
 528     my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
 529     while (my $line = <$orig>) {
 530         my ($file) = $line =~ /^(\S+)/
 531             or die "Can't parse MANIFEST line: $line";
 532         print $new $line if !$gone{$file};
 533     }
 534
 535     say $new "cpan/$pkg_dir/$_" for @commit;
 536
 537     close $new or die "Can't close $MANIFEST: $!\n";
 538
 539     system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
 540     unlink $MANIFEST_NEW
 541         or die "Can't delete temporary $MANIFEST_NEW: $!\n";
 542 }
 543
 544
 545 print "Running a make and saving its output to $MAKE_LOG ... ";
 546 # Prepare for running (selected) tests
 547 make 'test-prep';
 548 print "done\n";
 549
 550 # The build system installs code from CPAN dists into the lib/ directory,
 551 # creating directories as needed. This means that the cleaning-related rules
 552 # in the Makefile need to know which directories to clean up. The Makefile
 553 # is generated by Configure from Makefile.SH, so *that* file needs the list
 554 # of directories. regen/lib_cleanup.pl is capable of automatically updating
 555 # the contents of Makefile.SH (and win32/Makefile, which needs similar but
 556 # not identical lists of directories), so we can just run that (using the
 557 # newly-built Perl, as is done with the regen programs run by "make regen").
 558 #
 559 # We do this if any files at all have been added or deleted, regardless of
 560 # whether those changes result in any directories being added or deleted,
 561 # because the alternative would be to replicate the regen/lib_cleanup.pl
 562 # logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
 563 # repeatedly.
 564 if (@commit || @gone) {
 565     say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
 566     my $exe_dir = WIN32 ? ".\\" : './';
 567     system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
 568         and die "regen/lib_cleanup.pl failed\n";
 569 }
 570
 571 #
 572 # Must clean up, or else t/porting/FindExt.t will fail.
 573 # Note that we can always retrieve the original directory with a git checkout.
 574 #
 575 print "About to clean up; hit return or abort (^C) "; <STDIN>;
 576
 577 remove_tree( "cpan/$old_dir" );
 578 unlink "cpan/$new_file" unless $tarball;
 579
 580 #
 581 # Run the tests. First the test belonging to the module, followed by the
 582 # the tests in t/porting
 583 #
 584 chdir "t";
 585 say "Running module tests";
 586 my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
 587 my $exe_dir = WIN32 ? "..\\" : './';
 588 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
 589 unless ($output =~ /All tests successful/) {
 590     say $output;
 591     exit 1;
 592 }
 593
 594 print "Running tests in t/porting ";
 595 my @tests = glob 'porting/*.t';
 596 chomp @tests;
 597 my @failed;
 598 foreach my $t (@tests) {
 599     my @not = grep {!/# TODO/ }
 600               grep { /^not/ }
 601               `${exe_dir}perl -I../lib -I.. $t`;
 602     print @not ? '!' : '.';
 603     push @failed => $t if @not;
 604 }
 605 print "\n";
 606 say "Failed tests: @failed" if @failed;
 607
 608
 609 chdir '..';
 610
 611 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
 612 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
 613
 614 my $found;
 615 my $in_mod_section;
 616 while (<$Maintainers_pl>) {
 617     if (!$found) {
 618         if ($in_mod_section) {
 619             if (/DISTRIBUTION/) {
 620                 if (s/\Q$old_version/$new_version/) {
 621                     $found = 1;
 622                 }
 623             }
 624
 625             if (/^    \}/) {
 626                 $in_mod_section = 0;
 627             }
 628         }
 629
 630         if (/\Q$module/) {
 631             $in_mod_section = 1;
 632         }
 633     }
 634
 635     print $new_Maintainers_pl $_;
 636 }
 637
 638 if ($found) {
 639     say "Successfully updated Maintainers.pl";
 640     unlink 'Porting/Maintainers.pl';
 641     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
 642     chmod 0755 => 'Porting/Maintainers.pl';
 643 }
 644 else {
 645     say "Could not update Porting/Maintainers.pl.";
 646     say "Make sure you update this by hand before committing.";
 647 }
 648
 649 print <<"EOF";
 650
 651 =======================================================================
 652
 653 $o_module is now at version $new_version
 654 Next, you should run a "make test".
 655
 656 Hopefully that will complete successfully, but if not, you can make any
 657 changes you need to get the tests to pass. Don't forget that you'll need
 658 a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
 659 files under cpan/$pkg_dir.
 660
 661 Once all tests pass, you can "git add -u" and "git commit" the changes.
 662
 663 EOF
 664
 665 __END__