view release on metacpan or  search on metacpan

lib/BEGIN/Lift.pm  view on Meta::CPAN

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__

=pod

=head1 NAME

BEGIN::Lift - Lift subroutine calls into the BEGIN phase

=head1 SYNOPSIS

  package Cariboo;
  use strict;
  use warnings;

  use BEGIN::Lift;

  sub import {
      my $caller = caller;

      BEGIN::Lift::install(
          ($caller, 'extends') => sub {
              no strict 'refs';
              @{$caller . '::ISA'} = @_;
          }
      );
  }

  package Foo;
  use Cariboo;

  extends 'Bar';

  # functionally equivalent to ...
  # BEGIN { @ISA = ('Bar') }

=head1 DESCRIPTION

This module serves a very specific purpose, which is to provide a
mechanism through which we can "lift" a given subroutine to be
executed entirely within the C<BEGIN> phase of the Perl compiler
and to leave no trace of itself in the C<RUN> phase.

=head2 Modules loaded at runtime?

If a package that uses this module is loaded at runtime (perhaps
via the C<require> builtin), it will still work correctly (to the
best of my knowledge that is).