path: root/Porting/sync-with-cpan

#!/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 *

Updates the contents of 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 OPTIONS

=over 4

=item C<--jobs> I<N>

When running C<make>, pass a C<< -jI<N> >> option to it.

=back

=head1 TODO

=over 4

=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 File::Spec::Functions qw( tmpdir );
use Config qw( %Config );

$| = 1;

use constant WIN32 => $^O eq 'MSWin32';

die "This does not look like a top level directory"
     unless -d "cpan" && -d "Porting";

# Check that there's a Makefile, if needed; otherwise, we'll do most of our
# work only to fail when we try to run make, and the user will have to
# either unpick everything we've done, or do the rest manually.
die "Please run Configure before using $0\n"
    if !WIN32 && !-f "Makefile";

our @IGNORABLE;
our %Modules;

use autodie;

require "Porting/Maintainers.pl";

my $MAKE_LOG = 'make.log';

my %IGNORABLE    = map {$_ => 1} @IGNORABLE;

my $tmpdir = tmpdir();

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
);


sub usage
{
    my $err = shift and select STDERR;
    print "Usage: $0 module [args] [cpan package]\n";
    exit $err;
}

GetOptions ('tarball=s'  =>  \my $tarball,
            'version=s'  =>  \my $version,
            'jobs=i'     =>  \my $make_jobs,
             force       =>  \my $force,
             help        =>  sub { usage 0; },
             ) or  die "Failed to parse arguments";

usage 1 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= @_;
    unshift @args, "-j$make_jobs" if defined $make_jobs;
    if (WIN32) {
        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 $info = $Modules{$module};
if (!$info) {
    # Maybe the user said "Test-Simple" instead of "Test::Simple". See if we
    # can fix it up.
    (my $guess = $module) =~ s/-/::/g;
    $info = $Modules{$guess}
        or die "Cannot find module $module";
    say "Guessing you meant $guess instead of $module";
    $module = $guess;
}

my $cpan_mod = @ARGV ? shift : $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.]+(?:-TRIAL[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;
if (defined $tarball) {
    $new_file     = $tarball;
    $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
}
else {
    #
    # 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;
}

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 || @gone) {
    say "Fixing MANIFEST";
    my $MANIFEST     = "MANIFEST";
    my $MANIFEST_NEW = "$MANIFEST.new";

    open my $orig, "<", $MANIFEST
        or die "Failed to open $MANIFEST for reading: $!\n";
    open my $new, ">", $MANIFEST_NEW
        or die "Failed to open $MANIFEST_NEW for writing: $!\n";
    my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
    while (my $line = <$orig>) {
        my ($file) = $line =~ /^(\S+)/
            or die "Can't parse MANIFEST line: $line";
        print $new $line if !$gone{$file};
    }

    say $new "cpan/$pkg_dir/$_" for @commit;

    close $new or die "Can't close $MANIFEST: $!\n";

    system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
    unlink $MANIFEST_NEW
        or die "Can't delete temporary $MANIFEST_NEW: $!\n";
}


print "Running a make and saving its output to $MAKE_LOG ... ";
# Prepare for running (selected) tests
make 'test-prep';
print "done\n";

# The build system installs code from CPAN dists into the lib/ directory,
# creating directories as needed. This means that the cleaning-related rules
# in the Makefile need to know which directories to clean up. The Makefile
# is generated by Configure from Makefile.SH, so *that* file needs the list
# of directories. regen/lib_cleanup.pl is capable of automatically updating
# the contents of Makefile.SH (and win32/Makefile, which needs similar but
# not identical lists of directories), so we can just run that (using the
# newly-built Perl, as is done with the regen programs run by "make regen").
#
# We do this if any files at all have been added or deleted, regardless of
# whether those changes result in any directories being added or deleted,
# because the alternative would be to replicate the regen/lib_cleanup.pl
# logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
# repeatedly.
if (@commit || @gone) {
    say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
    my $exe_dir = WIN32 ? ".\\" : './';
    system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
        and die "regen/lib_cleanup.pl failed\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( "../cpan/$pkg_dir" );
my $exe_dir = WIN32 ? "..\\" : './';
$ENV{TEST_JOBS} = $_ for grep defined, $make_jobs;
my $output = `${exe_dir}perl$Config{_exe} -I../lib harness @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;


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) {
    say "Successfully updated Maintainers.pl";
    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.";
}

print <<"EOF";

=======================================================================

$o_module is now at version $new_version
Next, you should run a "make test".

Hopefully that will complete successfully, but if not, you can make any
changes you need to get the tests to pass. Don't forget that you'll need
a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
files under cpan/$pkg_dir.

Once all tests pass, you can "git add -u" and "git commit" the changes.

EOF

__END__