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