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 rel2abs );
 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 use Cwd 'cwd';
 286 my $orig_pwd = cwd();
 287
 288 chdir "cpan";
 289
 290 my  $pkg_dir      = $files[0];
 291     $pkg_dir      =~ s!.*/!!;
 292
 293 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
 294
 295 my  $o_module     = $module;
 296 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
 297     $cpan_mod =~ s/-/::/g;
 298 }
 299
 300 sub wget {
 301     my ($url, $saveas) = @_;
 302     eval {
 303         require HTTP::Tiny;
 304         my $http= HTTP::Tiny->new();
 305         $http->mirror( $url => $saveas );
 306         1
 307     } or
 308        # Some system do not have wget.  Fall back to curl if we do not
 309        # have it.  On Windows, `which wget` is not going to work, so
 310        # just use wget, as this script has always done.
 311        WIN32 || -x substr(`which wget`, 0, -1)
 312          ? system wget => $url, '-qO', $saveas
 313          : system curl => $url, '-sSo', $saveas;
 314 }
 315
 316 #
 317 # Find the information from CPAN.
 318 #
 319 my $new_file;
 320 my $new_version;
 321 if (defined $tarball) {
 322     $tarball = rel2abs( $tarball, $orig_pwd ) ;
 323     die "Tarball $tarball does not exist\n" if !-e $tarball;
 324     die "Tarball $tarball is not a plain file\n" if !-f _;
 325     $new_file     = $tarball;
 326     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
 327     die "Blead and that tarball both have version $new_version of $module\n"
 328         if $new_version eq $old_version;
 329 }
 330 else {
 331     #
 332     # Poor man's cache
 333     #
 334     unless (-f $package_file && -M $package_file < 1) {
 335         wget $package_url, $package_file;
 336     }
 337
 338     open my $fh, '<', $package_file;
 339     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
 340                      or die "Cannot find $cpan_mod on CPAN\n";
 341     (undef, $new_version, my $new_path) = split ' ', $new_line;
 342     if (defined $version) {
 343         $new_path =~ s/-$new_version\./-$version\./;
 344         $new_version = $version;
 345     }
 346     $new_file = (split '/', $new_path) [-1];
 347
 348     die "The latest version of $module is $new_version, but blead already has it\n"
 349         if $new_version eq $old_version;
 350
 351     my $url = "https://cpan.metacpan.org/authors/id/$new_path";
 352     say "Fetching $url";
 353     #
 354     # Fetch the new distro
 355     #
 356     wget $url, $new_file;
 357 }
 358
 359 my  $old_dir      = "$pkg_dir-$old_version";
 360
 361 say "Cleaning out old directory";
 362 system git => 'clean', '-dfxq', $pkg_dir;
 363
 364 say "Unpacking $new_file";
 365 Archive::Tar->extract_archive( $new_file );
 366
 367 (my $new_dir = basename($new_file)) =~ s/\.tar\.gz//;
 368 # ensure 'make' will update all files
 369 my $t= time;
 370 for my $file (find_type_f($new_dir)) {
 371     make_writable($file); # for convenience if the user later edits it
 372     utime($t,$t,$file);
 373 };
 374
 375 say "Renaming directories";
 376 rename $pkg_dir => $old_dir;
 377
 378 say "Creating new package directory";
 379 mkdir $pkg_dir;
 380
 381 say "Populating new package directory";
 382 my $map = $$info {MAP};
 383 my @EXCLUDED_QR;
 384 my %EXCLUDED_QQ;
 385 if ($$info {EXCLUDED}) {
 386     foreach my $entry (@{$$info {EXCLUDED}}) {
 387         if (ref $entry) {push @EXCLUDED_QR => $entry}
 388         else            {$EXCLUDED_QQ {$entry} = 1}
 389     }
 390 }
 391
 392 FILE: for my $file ( find_type_f( $new_dir )) {
 393     my $old_file = $file;
 394     $file =~ s{^$new_dir/}{};
 395
 396     next if $EXCLUDED_QQ{$file};
 397     for my $qr (@EXCLUDED_QR) {
 398         next FILE if $file =~ $qr;
 399     }
 400
 401     if ( $map ) {
 402         for my $key ( sort { length $b <=> length $a } keys %$map ) {
 403             my $val = $map->{$key};
 404             last if $file =~ s/^$key/$val/;
 405         }
 406     }
 407     else {
 408         $file = $files[0] . '/' . $file;
 409     }
 410
 411     if ( $file =~ m{^cpan/} ) {
 412         $file =~ s{^cpan/}{};
 413     }
 414     else {
 415         $file = '../' . $file;
 416     }
 417
 418     my $prefix = '';
 419     my @parts = split '/', $file;
 420     pop @parts;
 421     for my $part (@parts) {
 422         $prefix .= '/' if $prefix;
 423         $prefix .= $part;
 424         mkdir $prefix unless -d $prefix;
 425     }
 426
 427     rename $old_file => $file;
 428 }
 429 remove_tree( $new_dir );
 430
 431 if (-f "$old_dir/.gitignore") {
 432     say "Restoring .gitignore";
 433     system git => 'checkout', "$pkg_dir/.gitignore";
 434 }
 435
 436 my @new_files = find_type_f( $pkg_dir );
 437 @new_files = grep {$_ ne $pkg_dir} @new_files;
 438 s!^[^/]+/!! for @new_files;
 439 my %new_files = map {$_ => 1} @new_files;
 440
 441 my @old_files = find_type_f( $old_dir );
 442 @old_files = grep {$_ ne $old_dir} @old_files;
 443 s!^[^/]+/!! for @old_files;
 444 my %old_files = map {$_ => 1} @old_files;
 445
 446 my @delete;
 447 my @commit;
 448 my @gone;
 449 FILE:
 450 foreach my $file (@new_files) {
 451     next if -d "$pkg_dir/$file";   # Ignore directories.
 452     next if $old_files {$file};    # It's already there.
 453     if ($IGNORABLE {$file}) {
 454         push @delete => $file;
 455         next;
 456     }
 457     push @commit => $file;
 458 }
 459 foreach my $file (@old_files) {
 460     next if -d "$old_dir/$file";
 461     next if $new_files {$file};
 462     push @gone => $file;
 463 }
 464
 465 #
 466 # Find all files with an exec bit
 467 #
 468 my @exec = find_type_f( $pkg_dir );
 469 my @de_exec;
 470 foreach my $file (@exec) {
 471     # Remove leading dir
 472     $file =~ s!^[^/]+/!!;
 473     if ($file =~ m!^t/!) {
 474         push @de_exec => $file;
 475         next;
 476     }
 477     # Check to see if the file exists; if it doesn't and doesn't have
 478     # the exec bit, remove it.
 479     if ($old_files {$file}) {
 480         unless (-x "$old_dir/$file") {
 481             push @de_exec => $file;
 482         }
 483     }
 484 }
 485
 486 #
 487 # No need to change the +x bit on files that will be deleted.
 488 #
 489 if (@de_exec && @delete) {
 490     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
 491     @de_exec = grep {!$delete {$_}} @de_exec;
 492 }
 493
 494 #
 495 # Mustn't change the +x bit on files that are whitelisted
 496 #
 497 if (@de_exec) {
 498     my %permitted = map { (my $x = $_) =~ tr/\n//d; $x => 1 } grep !/^#/,
 499         do { local @ARGV = '../Porting/exec-bit.txt'; <> };
 500     @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
 501 }
 502
 503 say "unlink $pkg_dir/$_" for @delete;
 504 say "git add $pkg_dir/$_" for @commit;
 505 say "git rm -f $pkg_dir/$_" for @gone;
 506 say "chmod a-x $pkg_dir/$_" for @de_exec;
 507
 508 print "Hit return to continue; ^C to abort "; <STDIN>;
 509
 510 unlink "$pkg_dir/$_"                      for @delete;
 511 system git   => 'add', "$pkg_dir/$_"      for @commit;
 512 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
 513 de_exec( "$pkg_dir/$_" )                  for @de_exec;
 514
 515 #
 516 # Restore anything that is customized.
 517 # We don't really care whether we've deleted the file - since we
 518 # do a git restore, it's going to be resurrected if necessary.
 519 #
 520 if ($$info {CUSTOMIZED}) {
 521     say "Restoring customized files";
 522     foreach my $file (@{$$info {CUSTOMIZED}}) {
 523         system git => "checkout", "$pkg_dir/$file";
 524     }
 525 }
 526
 527 chdir "..";
 528 if (@commit || @gone) {
 529     say "Fixing MANIFEST";
 530     my $MANIFEST     = "MANIFEST";
 531     my $MANIFEST_NEW = "$MANIFEST.new";
 532
 533     open my $orig, "<", $MANIFEST
 534         or die "Failed to open $MANIFEST for reading: $!\n";
 535     open my $new, ">", $MANIFEST_NEW
 536         or die "Failed to open $MANIFEST_NEW for writing: $!\n";
 537     my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
 538     while (my $line = <$orig>) {
 539         my ($file) = $line =~ /^(\S+)/
 540             or die "Can't parse MANIFEST line: $line";
 541         print $new $line if !$gone{$file};
 542     }
 543
 544     say $new "cpan/$pkg_dir/$_" for @commit;
 545
 546     close $new or die "Can't close $MANIFEST: $!\n";
 547
 548     system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
 549     unlink $MANIFEST_NEW
 550         or die "Can't delete temporary $MANIFEST_NEW: $!\n";
 551 }
 552
 553
 554 print "Running a make and saving its output to $MAKE_LOG ... ";
 555 # Prepare for running (selected) tests
 556 make 'test-prep';
 557 print "done\n";
 558
 559 # The build system installs code from CPAN dists into the lib/ directory,
 560 # creating directories as needed. This means that the cleaning-related rules
 561 # in the Makefile need to know which directories to clean up. The Makefile
 562 # is generated by Configure from Makefile.SH, so *that* file needs the list
 563 # of directories. regen/lib_cleanup.pl is capable of automatically updating
 564 # the contents of Makefile.SH (and win32/Makefile, which needs similar but
 565 # not identical lists of directories), so we can just run that (using the
 566 # newly-built Perl, as is done with the regen programs run by "make regen").
 567 #
 568 # We do this if any files at all have been added or deleted, regardless of
 569 # whether those changes result in any directories being added or deleted,
 570 # because the alternative would be to replicate the regen/lib_cleanup.pl
 571 # logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
 572 # repeatedly.
 573 if (@commit || @gone) {
 574     say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
 575     my $exe_dir = WIN32 ? ".\\" : './';
 576     system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
 577         and die "regen/lib_cleanup.pl failed\n";
 578 }
 579
 580 #
 581 # Must clean up, or else t/porting/FindExt.t will fail.
 582 # Note that we can always retrieve the original directory with a git checkout.
 583 #
 584 print "About to clean up; hit return or abort (^C) "; <STDIN>;
 585
 586 remove_tree( "cpan/$old_dir" );
 587 unlink "cpan/$new_file" unless $tarball;
 588
 589 #
 590 # Run the tests. First the test belonging to the module, followed by the
 591 # the tests in t/porting
 592 #
 593 chdir "t";
 594 say "Running module tests";
 595 my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
 596 my $exe_dir = WIN32 ? "..\\" : './';
 597 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
 598 unless ($output =~ /All tests successful/) {
 599     say $output;
 600     exit 1;
 601 }
 602
 603 print "Running tests in t/porting ";
 604 my @tests = glob 'porting/*.t';
 605 chomp @tests;
 606 my @failed;
 607 foreach my $t (@tests) {
 608     my @not = grep {!/# TODO/ }
 609               grep { /^not/ }
 610               `${exe_dir}perl -I../lib -I.. $t`;
 611     print @not ? '!' : '.';
 612     push @failed => $t if @not;
 613 }
 614 print "\n";
 615 say "Failed tests: @failed" if @failed;
 616
 617
 618 chdir '..';
 619
 620 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
 621 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
 622
 623 my $found;
 624 my $in_mod_section;
 625 while (<$Maintainers_pl>) {
 626     if (!$found) {
 627         if ($in_mod_section) {
 628             if (/DISTRIBUTION/) {
 629                 if (s/\Q$old_version/$new_version/) {
 630                     $found = 1;
 631                 }
 632             }
 633
 634             if (/^    \}/) {
 635                 $in_mod_section = 0;
 636             }
 637         }
 638
 639         if (/\Q$module/) {
 640             $in_mod_section = 1;
 641         }
 642     }
 643
 644     print $new_Maintainers_pl $_;
 645 }
 646
 647 if ($found) {
 648     say "Successfully updated Maintainers.pl";
 649     unlink 'Porting/Maintainers.pl';
 650     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
 651     chmod 0755 => 'Porting/Maintainers.pl';
 652 }
 653 else {
 654     say "Could not update Porting/Maintainers.pl.";
 655     say "Make sure you update this by hand before committing.";
 656 }
 657
 658 print <<"EOF";
 659
 660 =======================================================================
 661
 662 $o_module is now at version $new_version
 663 Next, you should run a "make test".
 664
 665 Hopefully that will complete successfully, but if not, you can make any
 666 changes you need to get the tests to pass. Don't forget that you'll need
 667 a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
 668 files under cpan/$pkg_dir.
 669
 670 Once all tests pass, you can "git add -u" and "git commit" the changes.
 671
 672 EOF
 673
 674 __END__