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 wget, git, tar, chmod, perl, make, and rm
 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
 132 $| = 1;
 133
 134 die "This does not look like a top level directory"
 135      unless -d "cpan" && -d "Porting";
 136
 137 our @IGNORABLE;
 138 our %Modules;
 139
 140 use autodie;
 141
 142 require "Porting/Maintainers.pl";
 143
 144 my %IGNORABLE    = map {$_ => 1} @IGNORABLE;
 145
 146 my $package      = "02packages.details.txt";
 147 my $package_url  = "http://www.cpan.org/modules/$package";
 148 my $package_file = "/tmp/$package";
 149
 150 my @problematic = (
 151     'podlators', # weird CUSTOMIZED section due to .PL files
 152 );
 153
 154
 155 GetOptions ('tarball=s'  =>  \my $tarball,
 156             'version=s'  =>  \my $version,
 157              force       =>  \my $force,)
 158         or  die "Failed to parse arguments";
 159
 160 die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2;
 161
 162 my ($module)  = shift;
 163 my  $cpan_mod = @ARGV ? shift : $module;
 164
 165
 166 my  $info         = $Modules {$module} or die "Cannot find module $module";
 167 my  $distribution = $$info {DISTRIBUTION};
 168
 169 my @files         = glob $$info {FILES};
 170 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
 171     say "This looks like a setup $0 cannot handle (yet)";
 172     unless ($force) {
 173         say "Will not continue without a --force option";
 174         exit 1;
 175     }
 176     say "--force is in effect, so we'll soldier on. Wish me luck!";
 177 }
 178
 179
 180 chdir "cpan";
 181
 182 my  $pkg_dir      = $files[0];
 183     $pkg_dir      =~ s!.*/!!;
 184
 185 my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/;
 186
 187 my  $o_module     = $module;
 188 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
 189     $cpan_mod =~ s/-/::/g;
 190 }
 191
 192 #
 193 # Find the information from CPAN.
 194 #
 195 my $new_file;
 196 my $new_version;
 197 unless ($tarball) {
 198     #
 199     # Poor man's cache
 200     #
 201     unless (-f $package_file && -M $package_file < 1) {
 202         system wget => $package_url, '-qO', $package_file;
 203     }
 204
 205     my  $new_line = `grep '^$cpan_mod ' $package_file`
 206                      or die "Cannot find $cpan_mod on CPAN\n";
 207     chomp $new_line;
 208     (undef, $new_version, my $new_path) = split ' ', $new_line;
 209     if (defined $version) {
 210         $new_path =~ s/-$new_version\./-$version\./;
 211         $new_version = $version;
 212     }
 213     $new_file = (split '/', $new_path) [-1];
 214
 215     my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
 216     say "Fetching $url";
 217     #
 218     # Fetch the new distro
 219     #
 220     system wget => $url, '-qO', $new_file;
 221 }
 222 else {
 223     $new_file     = $tarball;
 224     $new_version  = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0];
 225 }
 226
 227 my  $old_dir      = "$pkg_dir-$old_version";
 228
 229 say "Cleaning out old directory";
 230 system git => 'clean', '-dfxq', $pkg_dir;
 231
 232 say "Unpacking $new_file";
 233 Archive::Tar->extract_archive( $new_file );
 234
 235 (my $new_dir = $new_file) =~ s/\.tar\.gz//;
 236 # ensure 'make' will update all files
 237 system('find', $new_dir, '-exec', 'touch', '{}', ';');
 238
 239 say "Renaming directories";
 240 rename $pkg_dir => $old_dir;
 241
 242 say "Creating new package directory";
 243 mkdir $pkg_dir;
 244
 245 say "Populating new package directory";
 246 my $map = $$info {MAP};
 247 my @EXCLUDED_QR;
 248 my %EXCLUDED_QQ;
 249 if ($$info {EXCLUDED}) {
 250     foreach my $entry (@{$$info {EXCLUDED}}) {
 251         if (ref $entry) {push @EXCLUDED_QR => $entry}
 252         else            {$EXCLUDED_QQ {$entry} = 1}
 253     }
 254 }
 255
 256 FILE: for my $file ( `find $new_dir -type f` ) {
 257     chomp $file;
 258     my $old_file = $file;
 259     $file =~ s{^$new_dir/}{};
 260
 261     next if $EXCLUDED_QQ{$file};
 262     for my $qr (@EXCLUDED_QR) {
 263         next FILE if $file =~ $qr;
 264     }
 265
 266     if ( $map ) {
 267         for my $key ( sort { length $b <=> length $a } keys %$map ) {
 268             my $val = $map->{$key};
 269             last if $file =~ s/^$key/$val/;
 270         }
 271     }
 272     else {
 273         $file = $files[0] . '/' . $file;
 274     }
 275
 276     if ( $file =~ m{^cpan/} ) {
 277         $file =~ s{^cpan/}{};
 278     }
 279     else {
 280         $file = '../' . $file;
 281     }
 282
 283     my $prefix = '';
 284     my @parts = split '/', $file;
 285     pop @parts;
 286     for my $part (@parts) {
 287         $prefix .= '/' if $prefix;
 288         $prefix .= $part;
 289         mkdir $prefix unless -d $prefix;
 290     }
 291
 292     rename $old_file => $file;
 293 }
 294 system 'rm', '-rf', $new_dir;
 295
 296 if (-f "$old_dir/.gitignore") {
 297     say "Restoring .gitignore";
 298     system git => 'checkout', "$pkg_dir/.gitignore";
 299 }
 300
 301 my @new_files = `find $pkg_dir -type f`;
 302 chomp @new_files;
 303 @new_files = grep {$_ ne $pkg_dir} @new_files;
 304 s!^[^/]+/!! for @new_files;
 305 my %new_files = map {$_ => 1} @new_files;
 306
 307 my @old_files = `find $old_dir -type f`;
 308 chomp @old_files;
 309 @old_files = grep {$_ ne $old_dir} @old_files;
 310 s!^[^/]+/!! for @old_files;
 311 my %old_files = map {$_ => 1} @old_files;
 312
 313 my @delete;
 314 my @commit;
 315 my @gone;
 316 FILE:
 317 foreach my $file (@new_files) {
 318     next if -d "$pkg_dir/$file";   # Ignore directories.
 319     next if $old_files {$file};    # It's already there.
 320     if ($IGNORABLE {$file}) {
 321         push @delete => $file;
 322         next;
 323     }
 324     push @commit => $file;
 325 }
 326 foreach my $file (@old_files) {
 327     next if -d "$old_dir/$file";
 328     next if $new_files {$file};
 329     push @gone => $file;
 330 }
 331
 332 #
 333 # Find all files with an exec bit
 334 #
 335 my @exec = `find $pkg_dir -type f -perm +111`;
 336 chomp @exec;
 337 my @de_exec;
 338 foreach my $file (@exec) {
 339     # Remove leading dir
 340     $file =~ s!^[^/]+/!!;
 341     if ($file =~ m!^t/!) {
 342         push @de_exec => $file;
 343         next;
 344     }
 345     # Check to see if the file exists; if it doesn't and doesn't have
 346     # the exec bit, remove it.
 347     if ($old_files {$file}) {
 348         unless (-x "$old_dir/$file") {
 349             push @de_exec => $file;
 350         }
 351     }
 352 }
 353
 354 #
 355 # No need to change the +x bit on files that will be deleted.
 356 #
 357 if (@de_exec && @delete) {
 358     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
 359     @de_exec = grep {!$delete {$_}} @de_exec;
 360 }
 361
 362 say "unlink $pkg_dir/$_" for @delete;
 363 say "git add $pkg_dir/$_" for @commit;
 364 say "git rm -f $pkg_dir/$_" for @gone;
 365 say "chmod a-x $pkg_dir/$_" for @de_exec;
 366
 367 print "Hit return to continue; ^C to abort "; <STDIN>;
 368
 369 unlink "$pkg_dir/$_"                      for @delete;
 370 system git   => 'add', "$pkg_dir/$_"      for @commit;
 371 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
 372 system chmod => 'a-x', "$pkg_dir/$_"      for @de_exec;
 373
 374 #
 375 # Restore anything that is customized.
 376 # We don't really care whether we've deleted the file - since we
 377 # do a git restore, it's going to be resurrected if necessary.
 378 #
 379 if ($$info {CUSTOMIZED}) {
 380     say "Restoring customized files";
 381     foreach my $file (@{$$info {CUSTOMIZED}}) {
 382         system git => "checkout", "$pkg_dir/$file";
 383     }
 384 }
 385
 386 chdir "..";
 387 if (@commit) {
 388     say "Fixing MANIFEST";
 389     my $MANIFEST      = "MANIFEST";
 390     my $MANIFEST_SORT = "$MANIFEST.sorted";
 391     open my $fh, ">>", $MANIFEST;
 392     say $fh "cpan/$pkg_dir/$_" for @commit;
 393     close $fh;
 394     system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
 395     rename $MANIFEST_SORT => $MANIFEST;
 396 }
 397
 398
 399 print "Running a make ... ";
 400 system "make > make.log 2>&1" and die "Running make failed, see make.log";
 401 print "done\n";
 402
 403 #
 404 # Must clean up, or else t/porting/FindExt.t will fail.
 405 # Note that we can always retrieve the original directory with a git checkout.
 406 #
 407 print "About to clean up; hit return or abort (^C) "; <STDIN>;
 408
 409 chdir "cpan";
 410 system rm => '-r', $old_dir;
 411 unlink $new_file unless $tarball;
 412
 413
 414 #
 415 # Run the tests. First the test belonging to the module, followed by the
 416 # the tests in t/porting
 417 #
 418 chdir "../t";
 419 say "Running module tests";
 420 my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`;
 421 chomp @test_files;
 422 my $output = `./perl TEST @test_files`;
 423 unless ($output =~ /All tests successful/) {
 424     say $output;
 425     exit 1;
 426 }
 427
 428 print "Running tests in t/porting ";
 429 my @tests = `ls porting/*.t`;
 430 chomp @tests;
 431 my @failed;
 432 foreach my $t (@tests) {
 433     my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`;
 434     print @not ? '!' : '.';
 435     push @failed => $t if @not;
 436 }
 437 print "\n";
 438 say "Failed tests: @failed" if @failed;
 439
 440
 441 say "Attempting to update Maintainers.pl";
 442 chdir '..';
 443
 444 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
 445 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
 446
 447 my $found;
 448 my $in_mod_section;
 449 while (<$Maintainers_pl>) {
 450     if (!$found) {
 451         if ($in_mod_section) {
 452             if (/DISTRIBUTION/) {
 453                 if (s/\Q$old_version/$new_version/) {
 454                     $found = 1;
 455                 }
 456             }
 457
 458             if (/^    }/) {
 459                 $in_mod_section = 0;
 460             }
 461         }
 462
 463         if (/\Q$cpan_mod/) {
 464             $in_mod_section = 1;
 465         }
 466     }
 467
 468     print $new_Maintainers_pl $_;
 469 }
 470
 471 if ($found) {
 472     unlink 'Porting/Maintainers.pl';
 473     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
 474     system chmod => 'a+x', 'Porting/Maintainers.pl';
 475 }
 476 else {
 477     say "Could not update Porting/Maintainers.pl.";
 478     say "Make sure you update this by hand before committing.";
 479 }
 480
 481 say "$o_module is now version $new_version";
 482 say "Now you ought to run a make; make test ...";
 483
 484
 485 __END__