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