File Coverage

blib/lib/Git/CPAN/Hook.pm

Criterion	Covered	Total	%
statement	46	70	65.7
branch	5	18	27.7
condition			n/a
subroutine	11	17	64.7
pod	1	4	25.0
total	63	109	57.8

package Git::CPAN::Hook;

use strict;
use warnings;
use Git::Repository;

our $VERSION = '0.03';

# the list of CPAN.pm methods we will replace
my %cpan;
my %hook = (
    'CPAN::Distribution::install'   => \&_install,
    'CPAN::HandleConfig::neatvalue' => \&_neatvalue,
);
my @keys = qw( __HOOK__ );

# if we were called from within CPAN.pm's configuration
_TSR_CPAN() if $INC{'CPAN.pm'};

#
# some private utilities
#
sub _TSR_CPAN {
    require CPAN;

    # actually replace the code in CPAN.pm
    _replace( $_ => $hook{$_} ) for keys %hook;

    # install our keys in CPAN.pm's config
    $CPAN::HandleConfig::keys{$_} = undef for @keys;
}

sub _replace {
    my ( $fullname, $meth ) = @_;
    my $name = ( split /::/, $fullname )[-1];
    no strict 'refs';
    no warnings 'redefine';
    $cpan{$name} = \&{$fullname};
    *$fullname = $meth;
}

sub _commit_all {
    my ($r, @args) = @_;

    # git add . fails on an empty repository for git between 1.5.3 and 1.6.3.2
    return if ! eval { $r->run( add => '.' ); 1; };

    # git status --porcelain exists only since git 1.7.0
    $r->run( commit => @args )
        if $r->version_lt('1.7.0')
        ? $r->run('status') !~ /^nothing to commit/m
        : $r->run( status => '--porcelain' );
}

sub import {
    my ($class) = @_;
    my $pkg = caller;

    # always export everything
    no strict 'refs';
    *{"$pkg\::$_"} = \&$_ for qw( install init uninstall );
}

#
# exported methods for repository setup
#

sub init {
    my ($path) = @_ ? @_ : @ARGV;

    # make this directory a Git repository
    Git::Repository->run( init => { cwd => $path } );
    my $r = Git::Repository->new( work_tree => $path );

    # activate it for Git::CPAN::Hook
    $r->run( qw( config cpan-hook.active true ) );

    # create an initial commit if needed (e.g. for local::lib)
    _commit_all( $r => -m => 'Initial commit' );

    # setup ignore list
    my $ignore = File::Spec->catfile( $path, '.gitignore' );
    open my $fh, '>>', $ignore or die "Can't open $ignore for appending: $!";
    print $fh "$_\n" for qw( .packlist perllocal.pod );
    close $fh;

    # git add won't accept an absolute path before 1.5.5
    $r->run( add => '.gitignore' );
    $r->run( commit => '-m', 'Basic files in an empty CPAN directory' );

    # tag as the empty root commit
    $r->run( tag => '-m', 'empty CPAN install, configured', 'empty' );
}

#
# exported methods for CPAN.pm hijacking
#

sub install {
    _TSR_CPAN;
    CPAN::HandleConfig->load();
    $CPAN::Config->{__HOOK__} = sub { };
    CPAN::HandleConfig->commit();
}

sub uninstall {
    _TSR_CPAN;
    CPAN::HandleConfig->load();
    delete $CPAN::Config->{$_} for @keys;
    CPAN::HandleConfig->commit();
}

#
# our replacements for some CPAN.pm methods
#

# commit after a successful install
sub _install {
    my $dist = $_[0];
    my @rv   = $cpan{install}->(@_);

    # do something only after a successful install
    if ( !$dist->{install}{FAILED} ) {
        __PACKAGE__->commit( $dist->{ID} );
    }

    # return what's expected
    return @rv;
}

# make sure we always get loaded
sub _neatvalue {
    my $nv = $cpan{neatvalue}->(@_);

    # CPAN's neatvalue just stringifies coderefs, which we then replace
    # with some code to hook us back in CPAN for next time
    return $nv =~ /^CODE/
        ? 'do { require Git::CPAN::Hook; sub { } }'
        : $nv;
}

#
# core methods, available to all CPAN clients
#
sub commit {
    my ( $class, $dist ) = @_;

    # assume distributions are always installed somewhere in @INC
    for my $inc ( grep -e, @INC ) {
        my $r = eval { Git::Repository->new( work_tree => $inc ); };
        next if !$r;    # not a Git repository

        # do not commit in random directories!
        next if $r->run(qw( config --bool cpan-hook.active )) ne 'true';

        # commit step
        _commit_all( $r => -m => $dist );
    }
}

1;

__END__