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