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