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 Adds new files to 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 TODO
  94
  95 =over 4
  96
  97 =item *
  98
  99 Delete files from F<MANIFEST>
 100
 101 =item *
 102
 103 Update F<Porting/Maintainers.pl>
 104
 105 =item *
 106
 107 Optional, run a full test suite
 108
 109 =item *
 110
 111 Handle complicated C<FILES>
 112
 113 =back
 114
 115 This is an initial version; no attempt has been made yet to make this
 116 portable. It shells out instead of trying to find a Perl solution.
 117 In particular, it assumes git, perl, and make
 118 to be available.
 119
 120 =cut
 121
 122
 123 package Maintainers;
 124
 125 use 5.010;
 126
 127 use strict;
 128 use warnings;
 129 use Getopt::Long;
 130 use Archive::Tar;
 131 use File::Path qw( remove_tree );
 132 use File::Find;
 133 use Config qw( %Config );
 134
 135 $| = 1;
 136
 137 die "This does not look like a top level directory"
 138      unless -d "cpan" && -d "Porting";
 139
 140 our @IGNORABLE;
 141 our %Modules;
 142
 143 use autodie;
 144
 145 require "Porting/Maintainers.pl";
 146
 147 my %IGNORABLE    = map {$_ => 1} @IGNORABLE;
 148
 149 my $tmpdir= $ENV{ TEMP } // '/tmp';
 150
 151 my $package      = "02packages.details.txt";
 152 my $package_url  = "http://www.cpan.org/modules/$package";
 153 my $package_file = "$tmpdir/$package"; # this is a cache
 154
 155 my @problematic = (
 156     'podlators', # weird CUSTOMIZED section due to .PL files
 157 );
 158
 159
 160 sub usage
 161 {
 162     my $err = shift and select STDERR;
 163     print "Usage: $0 module [args] [cpan package]\n";
 164     exit $err;
 165 }
 166
 167 GetOptions ('tarball=s'  =>  \my $tarball,
 168             'version=s'  =>  \my $version,
 169              force       =>  \my $force,
 170              help        =>  sub { usage 0; },
 171              ) or  die "Failed to parse arguments";
 172
 173 usage 1 unless @ARGV == 1 || @ARGV == 2;
 174
 175 sub find_type_f {
 176     my @res;
 177     find( { no_chdir => 1, wanted => sub {
 178         my $file= $File::Find::name;
 179         return unless -f $file;
 180         push @res, $file
 181     }}, @_ );
 182     @res
 183 };
 184
 185 # Equivalent of `chmod a-x`
 186 sub de_exec {
 187     for my $filename ( @_ ) {
 188         my $mode= (stat $filename)[2] & 0777;
 189         if( $mode & 0111 ) { # exec-bit set
 190             chmod $mode & 0666, $filename;
 191         };
 192     }
 193 }
 194
 195 sub make {
 196     my @args= @_;
 197     if( $^O eq 'MSWin32') {
 198         chdir "Win32";
 199         system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log";
 200         chdir '..';
 201     } else {
 202         system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log";
 203     };
 204 };
 205
 206 my ($module)  = shift;
 207 my  $cpan_mod = @ARGV ? shift : $module;
 208
 209
 210 my  $info         = $Modules {$module} or die "Cannot find module $module";
 211 my  $distribution = $$info {DISTRIBUTION};
 212
 213 my @files         = glob $$info {FILES};
 214 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
 215     say "This looks like a setup $0 cannot handle (yet)";
 216     unless ($force) {
 217         say "Will not continue without a --force option";
 218         exit 1;
 219     }
 220     say "--force is in effect, so we'll soldier on. Wish me luck!";
 221 }
 222
 223
 224 chdir "cpan";
 225
 226 my  $pkg_dir      = $files[0];
 227     $pkg_dir      =~ s!.*/!!;
 228
 229 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
 230
 231 my  $o_module     = $module;
 232 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
 233     $cpan_mod =~ s/-/::/g;
 234 }
 235
 236 #
 237 # Find the information from CPAN.
 238 #
 239 my $new_file;
 240 my $new_version;
 241 unless ($tarball) {
 242     #
 243     # Poor man's cache
 244     #
 245     unless (-f $package_file && -M $package_file < 1) {
 246         eval {
 247             require HTTP::Tiny;
 248             my $http= HTTP::Tiny->new();
 249             $http->mirror( $package_url => $package_file );
 250             1
 251         } or system wget => $package_url, '-qO', $package_file;
 252     }
 253
 254     open my $fh, '<', $package_file;
 255     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
 256                      or die "Cannot find $cpan_mod on CPAN\n";
 257     (undef, $new_version, my $new_path) = split ' ', $new_line;
 258     if (defined $version) {
 259         $new_path =~ s/-$new_version\./-$version\./;
 260         $new_version = $version;
 261     }
 262     $new_file = (split '/', $new_path) [-1];
 263
 264     my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
 265     say "Fetching $url";
 266     #
 267     # Fetch the new distro
 268     #
 269     eval {
 270         require HTTP::Tiny;
 271         my $http= HTTP::Tiny->new();
 272         $http->mirror( $url => $new_file );
 273         1
 274     } or system wget => $url, '-qO', $new_file;
 275 }
 276 else {
 277     $new_file     = $tarball;
 278     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
 279 }
 280
 281 my  $old_dir      = "$pkg_dir-$old_version";
 282
 283 say "Cleaning out old directory";
 284 system git => 'clean', '-dfxq', $pkg_dir;
 285
 286 say "Unpacking $new_file";
 287 Archive::Tar->extract_archive( $new_file );
 288
 289 (my $new_dir = $new_file) =~ s/\.tar\.gz//;
 290 # ensure 'make' will update all files
 291 my $t= time;
 292 for my $file (find_type_f($new_dir)) {
 293     open(my $fh,'>>',$file) || die "Cannot write $file:$!";
 294     close($fh);
 295     utime($t,$t,$file);
 296 };
 297
 298 say "Renaming directories";
 299 rename $pkg_dir => $old_dir;
 300
 301 say "Creating new package directory";
 302 mkdir $pkg_dir;
 303
 304 say "Populating new package directory";
 305 my $map = $$info {MAP};
 306 my @EXCLUDED_QR;
 307 my %EXCLUDED_QQ;
 308 if ($$info {EXCLUDED}) {
 309     foreach my $entry (@{$$info {EXCLUDED}}) {
 310         if (ref $entry) {push @EXCLUDED_QR => $entry}
 311         else            {$EXCLUDED_QQ {$entry} = 1}
 312     }
 313 }
 314
 315 FILE: for my $file ( find_type_f( $new_dir )) {
 316     my $old_file = $file;
 317     $file =~ s{^$new_dir/}{};
 318
 319     next if $EXCLUDED_QQ{$file};
 320     for my $qr (@EXCLUDED_QR) {
 321         next FILE if $file =~ $qr;
 322     }
 323
 324     if ( $map ) {
 325         for my $key ( sort { length $b <=> length $a } keys %$map ) {
 326             my $val = $map->{$key};
 327             last if $file =~ s/^$key/$val/;
 328         }
 329     }
 330     else {
 331         $file = $files[0] . '/' . $file;
 332     }
 333
 334     if ( $file =~ m{^cpan/} ) {
 335         $file =~ s{^cpan/}{};
 336     }
 337     else {
 338         $file = '../' . $file;
 339     }
 340
 341     my $prefix = '';
 342     my @parts = split '/', $file;
 343     pop @parts;
 344     for my $part (@parts) {
 345         $prefix .= '/' if $prefix;
 346         $prefix .= $part;
 347         mkdir $prefix unless -d $prefix;
 348     }
 349
 350     rename $old_file => $file;
 351 }
 352 remove_tree( $new_dir );
 353
 354 if (-f "$old_dir/.gitignore") {
 355     say "Restoring .gitignore";
 356     system git => 'checkout', "$pkg_dir/.gitignore";
 357 }
 358
 359 my @new_files = find_type_f( $pkg_dir );
 360 @new_files = grep {$_ ne $pkg_dir} @new_files;
 361 s!^[^/]+/!! for @new_files;
 362 my %new_files = map {$_ => 1} @new_files;
 363
 364 my @old_files = find_type_f( $old_dir );
 365 @old_files = grep {$_ ne $old_dir} @old_files;
 366 s!^[^/]+/!! for @old_files;
 367 my %old_files = map {$_ => 1} @old_files;
 368
 369 my @delete;
 370 my @commit;
 371 my @gone;
 372 FILE:
 373 foreach my $file (@new_files) {
 374     next if -d "$pkg_dir/$file";   # Ignore directories.
 375     next if $old_files {$file};    # It's already there.
 376     if ($IGNORABLE {$file}) {
 377         push @delete => $file;
 378         next;
 379     }
 380     push @commit => $file;
 381 }
 382 foreach my $file (@old_files) {
 383     next if -d "$old_dir/$file";
 384     next if $new_files {$file};
 385     push @gone => $file;
 386 }
 387
 388 #
 389 # Find all files with an exec bit
 390 #
 391 my @exec = find_type_f( $pkg_dir );
 392 my @de_exec;
 393 foreach my $file (@exec) {
 394     # Remove leading dir
 395     $file =~ s!^[^/]+/!!;
 396     if ($file =~ m!^t/!) {
 397         push @de_exec => $file;
 398         next;
 399     }
 400     # Check to see if the file exists; if it doesn't and doesn't have
 401     # the exec bit, remove it.
 402     if ($old_files {$file}) {
 403         unless (-x "$old_dir/$file") {
 404             push @de_exec => $file;
 405         }
 406     }
 407 }
 408
 409 #
 410 # No need to change the +x bit on files that will be deleted.
 411 #
 412 if (@de_exec && @delete) {
 413     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
 414     @de_exec = grep {!$delete {$_}} @de_exec;
 415 }
 416
 417 say "unlink $pkg_dir/$_" for @delete;
 418 say "git add $pkg_dir/$_" for @commit;
 419 say "git rm -f $pkg_dir/$_" for @gone;
 420 say "chmod a-x $pkg_dir/$_" for @de_exec;
 421
 422 print "Hit return to continue; ^C to abort "; <STDIN>;
 423
 424 unlink "$pkg_dir/$_"                      for @delete;
 425 system git   => 'add', "$pkg_dir/$_"      for @commit;
 426 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
 427 de_exec( "$pkg_dir/$_" )                  for @de_exec;
 428
 429 #
 430 # Restore anything that is customized.
 431 # We don't really care whether we've deleted the file - since we
 432 # do a git restore, it's going to be resurrected if necessary.
 433 #
 434 if ($$info {CUSTOMIZED}) {
 435     say "Restoring customized files";
 436     foreach my $file (@{$$info {CUSTOMIZED}}) {
 437         system git => "checkout", "$pkg_dir/$file";
 438     }
 439 }
 440
 441 chdir "..";
 442 if (@commit) {
 443     say "Fixing MANIFEST";
 444     my $MANIFEST      = "MANIFEST";
 445     my $MANIFEST_SORT = "$MANIFEST.sorted";
 446     open my $fh, ">>", $MANIFEST;
 447     say $fh "cpan/$pkg_dir/$_" for @commit;
 448     close $fh;
 449     system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
 450     rename $MANIFEST_SORT => $MANIFEST;
 451 }
 452
 453
 454 print "Running a make ... ";
 455 # Prepare for running (selected) tests
 456 make 'test-prep';
 457 print "done\n";
 458
 459 #
 460 # Must clean up, or else t/porting/FindExt.t will fail.
 461 # Note that we can always retrieve the original directory with a git checkout.
 462 #
 463 print "About to clean up; hit return or abort (^C) "; <STDIN>;
 464
 465 remove_tree( "cpan/$old_dir" );
 466 unlink "cpan/$new_file" unless $tarball;
 467
 468 #
 469 # Run the tests. First the test belonging to the module, followed by the
 470 # the tests in t/porting
 471 #
 472 chdir "t";
 473 say "Running module tests";
 474 my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir );
 475 my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './';
 476 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
 477 unless ($output =~ /All tests successful/) {
 478     say $output;
 479     exit 1;
 480 }
 481
 482 print "Running tests in t/porting ";
 483 my @tests = glob 'porting/*.t';
 484 chomp @tests;
 485 my @failed;
 486 foreach my $t (@tests) {
 487     my @not = grep {!/# TODO/ }
 488               grep { /^not/ }
 489               `${exe_dir}perl -I../lib -I.. $t`;
 490     print @not ? '!' : '.';
 491     push @failed => $t if @not;
 492 }
 493 print "\n";
 494 say "Failed tests: @failed" if @failed;
 495
 496
 497 say "Attempting to update Maintainers.pl";
 498 chdir '..';
 499
 500 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
 501 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
 502
 503 my $found;
 504 my $in_mod_section;
 505 while (<$Maintainers_pl>) {
 506     if (!$found) {
 507         if ($in_mod_section) {
 508             if (/DISTRIBUTION/) {
 509                 if (s/\Q$old_version/$new_version/) {
 510                     $found = 1;
 511                 }
 512             }
 513
 514             if (/^    }/) {
 515                 $in_mod_section = 0;
 516             }
 517         }
 518
 519         if (/\Q$cpan_mod/) {
 520             $in_mod_section = 1;
 521         }
 522     }
 523
 524     print $new_Maintainers_pl $_;
 525 }
 526
 527 if ($found) {
 528     unlink 'Porting/Maintainers.pl';
 529     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
 530     chmod 0755 => 'Porting/Maintainers.pl';
 531 }
 532 else {
 533     say "Could not update Porting/Maintainers.pl.";
 534     say "Make sure you update this by hand before committing.";
 535 }
 536
 537 say "$o_module is now version $new_version";
 538 say "Now you ought to run a make; make test ...";
 539
 540
 541 __END__