view release on metacpan or  search on metacpan

lib/B/Hooks/AtRuntime.pm  view on Meta::CPAN

package B::Hooks::AtRuntime;

use warnings;
use strict;

use XSLoader;
use Sub::Name       "subname";
use Carp;

use parent "Exporter::Tiny";
our @EXPORT     = qw/at_runtime/;
our @EXPORT_OK  = qw/at_runtime after_runtime lex_stuff/;

BEGIN {
    our $VERSION = "8";
    XSLoader::load __PACKAGE__, $VERSION;
}

use constant USE_FILTER =>
    defined $ENV{PERL_B_HOOKS_ATRUNTIME} 
        ? $ENV{PERL_B_HOOKS_ATRUNTIME} eq "filter"
        : not defined &lex_stuff;

if (USE_FILTER) {
    require Filter::Util::Call;

    # This isn't an exact replacement: it inserts the text at the start
    # of the next line, rather than immediately after the current BEGIN.
    #
    # In theory I could use B::Hooks::Parser, which aims to emulate
    # lex_stuff on older perls, but that uses a source filter to ensure
    # PL_linebuf has some extra space in it (since it can't be
    # reallocated without adjusting pointers we can't get to). This
    # means BHP::setup needs to be called at least one source line
    # before we want to insert any text (so the filter has a chance to
    # run), which makes it precisely useless for our purposes :(.

    no warnings "redefine";
    *lex_stuff = subname "lex_stuff", sub {
        my ($str) = @_;

        compiling_string_eval() and croak 
            "Can't stuff into a string eval";

        if (defined(my $extra = remaining_text())) {
            $extra =~ s/\n+\z//;
            carp "Extra text '$extra' after call to lex_stuff";
        }

        Filter::Util::Call::filter_add(sub {
            $_ = $str;
            Filter::Util::Call::filter_del();
            return 1;
        });
    };
}

# In order to avoid needing to stuff text into perl's lexer too often,
# the code stuffed looks like this
#
#   B::Hooks::AtRuntime::run(@B::Hooks::Runtime::hooks);
#   BEGIN { B::Hooks::Runtime::clear(1) }
#
# The way this works is as follows.
#
# - The @hooks global refers to a different array every time it is used.
#   The sub replace_hooks is responsible for making sure that the global
#   points to the correct array at the time the stuffed code is
#   compiled.
#
# - The lexical array @Hooks below contains one entry for each time we
#   have recursively entered compile time. So, for example, if the user
#   writes
#
#       BEGIN {
#           BEGIN {
#               at_runtime { ... };
#           }
#       }
#
#   then the at_runtime sub is pushed onto @Hooks[2], because we are in
#   our second recursive BEGIN. (@Hooks[0] is never used.)
#
# - The XS sub count_BEGINs is responsible for finding which level of
#   @Hooks to push onto. It does this by looking for BEGIN blocks,
#   because even use compiles out as a BEGIN block.
#
# - The call to clear() ensures that if we leave and re-enter compile
#   time at this level we get a new array of hooks and a new code-stuff
#   to call them. The number passed (interpolated into the compiled
#   code) is the level of @Hooks to clear.

my @Hooks;

sub replace_hooks {
    my ($new) = @_;

    # By deleting the stash entry we ensure the only ref to the glob is
    # through the optree it was compiled into. This means that if that
    # optree is ever freed, the glob will disappear along with anything
    # closed over by the user's callbacks.
    delete $B::Hooks::AtRuntime::{hooks};

    no strict "refs";
    $new and *{"hooks"} = $new;
}

sub clear {
    my ($depth) = @_;
    $Hooks[$depth] = undef;
    replace_hooks $Hooks[$depth - 1];
}

sub find_hooks {
    USE_FILTER and compiling_string_eval() and croak
        "Can't use at_runtime from a string eval";

    my $depth = count_BEGINs()
        or croak "You must call at_runtime at compile time";