#!/usr/bin/env perl
=head1 NAME
Porting/sync-with-cpan - Synchronize with CPAN distributions
=head1 SYNOPSIS
perl Porting/sync-with-cpan <module>
where <module> is the name it appears in the C<%Modules> hash
of F<Porting/Maintainers.pl>
=head1 DESCRIPTION
Script to help out with syncing cpan distros.
Does the following:
=over 4
=item *
Fetches the package list from CPAN. Finds the current version of the given
package. [1]
=item *
Downloads the relevant tarball; unpacks the tarball. [1]
=item *
Clean out the old directory (C<git clean -dfx>)
=item *
Moves the old directory out of the way, moves the new directory in place.
=item *
Restores any F<.gitignore> file.
=item *
Removes files from C<@IGNORE> and C<EXCLUDED>
=item *
C<git add> any new files.
=item *
C<git rm> any files that are gone.
=item *
Remove the +x bit on files in F<t/>
=item *
Remove the +x bit on files that don't have it enabled in the current dir
=item *
Restore files mentioned in C<CUSTOMIZED>
=item *
Adds new files to F<MANIFEST>
=item *
Runs a C<make> (assumes a configure has been run)
=item *
Cleans up
=item *
Runs tests for the package
=item *
Runs the porting tests
=back
[1] If the C<--tarball> option is given, then CPAN is not consulted.
C<--tarball> should be the path to the tarball; the version is extracted
from the filename -- but can be overwritten by the C<--version> option.
=head1 TODO
=over 4
=item *
Delete files from F<MANIFEST>
=item *
Update F<Porting/Maintainers.pl>
=item *
Optional, run a full test suite
=item *
Handle complicated C<FILES>
=back
This is an initial version; no attempt has been made yet to make this
portable. It shells out instead of trying to find a Perl solution.
In particular, it assumes git, perl, and make
to be available.
=cut
package Maintainers;
use 5.010;
use strict;
use warnings;
use Getopt::Long;
use Archive::Tar;
use File::Path qw( remove_tree );
use File::Find;
use Config qw( %Config );
$| = 1;
die "This does not look like a top level directory"
unless -d "cpan" && -d "Porting";
our @IGNORABLE;
our %Modules;
use autodie;
require "Porting/Maintainers.pl";
my %IGNORABLE = map {$_ => 1} @IGNORABLE;
my $tmpdir= $ENV{ TEMP } // '/tmp';
my $package = "02packages.details.txt";
my $package_url = "http://www.cpan.org/modules/$package";
my $package_file = "$tmpdir/$package"; # this is a cache
my @problematic = (
'podlators', # weird CUSTOMIZED section due to .PL files
);
GetOptions ('tarball=s' => \my $tarball,
'version=s' => \my $version,
force => \my $force,)
or die "Failed to parse arguments";
die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2;
sub find_type_f {
my @res;
find( { no_chdir => 1, wanted => sub {
my $file= $File::Find::name;
return unless -f $file;
push @res, $file
}}, @_ );
@res
};
# Equivalent of `chmod a-x`
sub de_exec {
for my $filename ( @_ ) {
my $mode= (stat $filename)[2] & 0777;
if( $mode & 0111 ) { # exec-bit set
chmod $mode & 0666, $filename;
};
}
}
sub make {
my @args= @_;
if( $^O eq 'MSWin32') {
chdir "Win32";
system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log";
chdir '..';
} else {
system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log";
};
};
my ($module) = shift;
my $cpan_mod = @ARGV ? shift : $module;
my $info = $Modules {$module} or die "Cannot find module $module";
my $distribution = $$info {DISTRIBUTION};
my @files = glob $$info {FILES};
if (!-d $files [0] || grep { $_ eq $module } @problematic) {
say "This looks like a setup $0 cannot handle (yet)";
unless ($force) {
say "Will not continue without a --force option";
exit 1;
}
say "--force is in effect, so we'll soldier on. Wish me luck!";
}
chdir "cpan";
my $pkg_dir = $files[0];
$pkg_dir =~ s!.*/!!;
my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/;
my $o_module = $module;
if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
$cpan_mod =~ s/-/::/g;
}
#
# Find the information from CPAN.
#
my $new_file;
my $new_version;
unless ($tarball) {
#
# Poor man's cache
#
unless (-f $package_file && -M $package_file < 1) {
eval {
require HTTP::Tiny;
my $http= HTTP::Tiny->new();
$http->mirror( $package_url => $package_file );
1
} or system wget => $package_url, '-qO', $package_file;
}
open my $fh, '<', $package_file;
(my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
or die "Cannot find $cpan_mod on CPAN\n";
(undef, $new_version, my $new_path) = split ' ', $new_line;
if (defined $version) {
$new_path =~ s/-$new_version\./-$version\./;
$new_version = $version;
}
$new_file = (split '/', $new_path) [-1];
my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
say "Fetching $url";
#
# Fetch the new distro
#
eval {
require HTTP::Tiny;
my $http= HTTP::Tiny->new();
$http->mirror( $url => $new_file );
1
} or system wget => $url, '-qO', $new_file;
}
else {
$new_file = $tarball;
$new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0];
}
my $old_dir = "$pkg_dir-$old_version";
say "Cleaning out old directory";
system git => 'clean', '-dfxq', $pkg_dir;
say "Unpacking $new_file";
Archive::Tar->extract_archive( $new_file );
(my $new_dir = $new_file) =~ s/\.tar\.gz//;
# ensure 'make' will update all files
my $t= time;
for my $file (find_type_f($new_dir)) {
open(my $fh,">>$file") || die "Cannot write $file:$!";
close($fh);
utime($t,$t,$file);
};
say "Renaming directories";
rename $pkg_dir => $old_dir;
say "Creating new package directory";
mkdir $pkg_dir;
say "Populating new package directory";
my $map = $$info {MAP};
my @EXCLUDED_QR;
my %EXCLUDED_QQ;
if ($$info {EXCLUDED}) {
foreach my $entry (@{$$info {EXCLUDED}}) {
if (ref $entry) {push @EXCLUDED_QR => $entry}
else {$EXCLUDED_QQ {$entry} = 1}
}
}
FILE: for my $file ( find_type_f( $new_dir )) {
my $old_file = $file;
$file =~ s{^$new_dir/}{};
next if $EXCLUDED_QQ{$file};
for my $qr (@EXCLUDED_QR) {
next FILE if $file =~ $qr;
}
if ( $map ) {
for my $key ( sort { length $b <=> length $a } keys %$map ) {
my $val = $map->{$key};
last if $file =~ s/^$key/$val/;
}
}
else {
$file = $files[0] . '/' . $file;
}
if ( $file =~ m{^cpan/} ) {
$file =~ s{^cpan/}{};
}
else {
$file = '../' . $file;
}
my $prefix = '';
my @parts = split '/', $file;
pop @parts;
for my $part (@parts) {
$prefix .= '/' if $prefix;
$prefix .= $part;
mkdir $prefix unless -d $prefix;
}
rename $old_file => $file;
}
remove_tree( $new_dir );
if (-f "$old_dir/.gitignore") {
say "Restoring .gitignore";
system git => 'checkout', "$pkg_dir/.gitignore";
}
my @new_files = find_type_f( $pkg_dir );
@new_files = grep {$_ ne $pkg_dir} @new_files;
s!^[^/]+/!! for @new_files;
my %new_files = map {$_ => 1} @new_files;
my @old_files = find_type_f( $old_dir );
@old_files = grep {$_ ne $old_dir} @old_files;
s!^[^/]+/!! for @old_files;
my %old_files = map {$_ => 1} @old_files;
my @delete;
my @commit;
my @gone;
FILE:
foreach my $file (@new_files) {
next if -d "$pkg_dir/$file"; # Ignore directories.
next if $old_files {$file}; # It's already there.
if ($IGNORABLE {$file}) {
push @delete => $file;
next;
}
push @commit => $file;
}
foreach my $file (@old_files) {
next if -d "$old_dir/$file";
next if $new_files {$file};
push @gone => $file;
}
#
# Find all files with an exec bit
#
my @exec = find_type_f( $pkg_dir );
my @de_exec;
foreach my $file (@exec) {
# Remove leading dir
$file =~ s!^[^/]+/!!;
if ($file =~ m!^t/!) {
push @de_exec => $file;
next;
}
# Check to see if the file exists; if it doesn't and doesn't have
# the exec bit, remove it.
if ($old_files {$file}) {
unless (-x "$old_dir/$file") {
push @de_exec => $file;
}
}
}
#
# No need to change the +x bit on files that will be deleted.
#
if (@de_exec && @delete) {
my %delete = map {+"$pkg_dir/$_" => 1} @delete;
@de_exec = grep {!$delete {$_}} @de_exec;
}
say "unlink $pkg_dir/$_" for @delete;
say "git add $pkg_dir/$_" for @commit;
say "git rm -f $pkg_dir/$_" for @gone;
say "chmod a-x $pkg_dir/$_" for @de_exec;
print "Hit return to continue; ^C to abort "; <STDIN>;
unlink "$pkg_dir/$_" for @delete;
system git => 'add', "$pkg_dir/$_" for @commit;
system git => 'rm', '-f', "$pkg_dir/$_" for @gone;
de_exec( "$pkg_dir/$_" ) for @de_exec;
#
# Restore anything that is customized.
# We don't really care whether we've deleted the file - since we
# do a git restore, it's going to be resurrected if necessary.
#
if ($$info {CUSTOMIZED}) {
say "Restoring customized files";
foreach my $file (@{$$info {CUSTOMIZED}}) {
system git => "checkout", "$pkg_dir/$file";
}
}
chdir "..";
if (@commit) {
say "Fixing MANIFEST";
my $MANIFEST = "MANIFEST";
my $MANIFEST_SORT = "$MANIFEST.sorted";
open my $fh, ">>", $MANIFEST;
say $fh "cpan/$pkg_dir/$_" for @commit;
close $fh;
system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
rename $MANIFEST_SORT => $MANIFEST;
}
print "Running a make ... ";
# Prepare for running (selected) tests
make 'test-prep';
print "done\n";
#
# Must clean up, or else t/porting/FindExt.t will fail.
# Note that we can always retrieve the original directory with a git checkout.
#
print "About to clean up; hit return or abort (^C) "; <STDIN>;
remove_tree( "cpan/$old_dir" );
unlink "cpan/$new_file" unless $tarball;
#
# Run the tests. First the test belonging to the module, followed by the
# the tests in t/porting
#
chdir "t";
say "Running module tests";
my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir );
my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './';
my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
unless ($output =~ /All tests successful/) {
say $output;
exit 1;
}
print "Running tests in t/porting ";
my @tests = glob 'porting/*.t';
chomp @tests;
my @failed;
foreach my $t (@tests) {
my @not = grep {!/# TODO/ }
grep { /^not/ }
`${exe_dir}perl -I../lib -I.. $t`;
print @not ? '!' : '.';
push @failed => $t if @not;
}
print "\n";
say "Failed tests: @failed" if @failed;
say "Attempting to update Maintainers.pl";
chdir '..';
open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
open my $new_Maintainers_pl, '>', 'Maintainers.pl';
my $found;
my $in_mod_section;
while (<$Maintainers_pl>) {
if (!$found) {
if ($in_mod_section) {
if (/DISTRIBUTION/) {
if (s/\Q$old_version/$new_version/) {
$found = 1;
}
}
if (/^ }/) {
$in_mod_section = 0;
}
}
if (/\Q$cpan_mod/) {
$in_mod_section = 1;
}
}
print $new_Maintainers_pl $_;
}
if ($found) {
unlink 'Porting/Maintainers.pl';
rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
chmod 0755 => 'Porting/Maintainers.pl';
}
else {
say "Could not update Porting/Maintainers.pl.";
say "Make sure you update this by hand before committing.";
}
say "$o_module is now version $new_version";
say "Now you ought to run a make; make test ...";
__END__