File Coverage

blib/lib/BEGIN/Lift.pm

Criterion	Covered	Total	%
statement	41	41	100.0
branch	6	6	100.0
condition			n/a
subroutine	12	12	100.0
pod	1	1	100.0
total	60	60	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 B::CompilerPhase::Hook ();

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

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

    # It does not make any sense to create
    # something that is meant to run in the
    # BEGIN phase *after* that phase is done
    # so catch this and error ...
    die 'Lifted keywords must be created during BEGIN time, not (' . ${^GLOBAL_PHASE}. ')'
        unless ${^GLOBAL_PHASE} eq 'START';

    # 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 ...
    B::CompilerPhase::Hook::enqueue_UNITCHECK {
        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__