File Coverage

blib/lib/BEGIN/Lift.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	4	4	100.0
condition			n/a
subroutine	12	12	100.0
pod	1	1	100.0
total	57	57	100.0

package BEGIN::Lift;
# ABSTRACT: Lift subroutine calls into the BEGIN phase

use strict;
use warnings;

our $VERSION;
our $AUTHORITY;

use Sub::Name   ();
use Devel::Hook ();

use Devel::CallParser;
use XSLoader;
BEGIN {
    $VERSION   = '0.07';
    $AUTHORITY = 'cpan:STEVAN';
    XSLoader::load( __PACKAGE__, $VERSION );
}

sub install {
    my ($pkg, $method, $handler) = @_;

    # need to force a new CV each time here
    # not entirely sure why, but I assume
    # that perl was trying to optimize things
    # which is not what I actually want.
    my $cv = eval 'sub {}';

    # now we need to install the stub
    # we just created, but first we need to
    # verify that we are the only ones using
    # the typeglob we are installing into.
    # This makes it easier/safer to delete
    # the stub before runtime.
    {
        no strict 'refs';
        die "Cannot install the lifted keyword ($method) into package ($pkg) when that typeglob (\*${pkg}::${method}) already exists"
            if exists ${"${pkg}::"}{$method};
        *{"${pkg}::${method}"} = $cv;
    }

    # give the handler a name so that
    # it shows up sensibly in stack
    # traces and the like ...
    Sub::Name::subname( "${pkg}::${method}", $handler );

    # install the keyword handler ...
    BEGIN::Lift::Util::install_keyword_handler(
        $cv, sub { $handler->( $_[0] ? $_[0]->() : () ) }
    );

    # clean things up ...
    Devel::Hook->unshift_UNITCHECK_hook(sub {
        no strict 'refs';
        # NOTE:
        # this is safe only because we
        # confirmed above that there was
        # no other use of this typeglob
        # and so it is ok to delete
        delete ${"${pkg}::"}{$method}
    });
}

1;

__END__