File Coverage

blib/lib/Method/Lexical.pm

Criterion	Covered	Total	%
statement	97	115	84.3
branch	24	42	57.1
condition	7	14	50.0
subroutine	15	19	78.9
pod			n/a
total	143	190	75.2

package Method::Lexical;

use 5.008001;

use strict;
use warnings;

use B::Hooks::EndOfScope;
use B::Hooks::OP::Check;
use B::Hooks::OP::Annotation;
use Carp qw(carp confess);
use Devel::Pragma qw(ccstash fqname my_hints new_scope on_require);
use XSLoader;

our $VERSION = '0.30';
our @CARP_NOT = qw(B::Hooks::EndOfScope);

XSLoader::load(__PACKAGE__, $VERSION);

my $DEBUG = xs_get_debug(); # flag indicating whether debug messages should be printed

# The key under which the $installed hash is installed in %^H i.e. 'Method::Lexical'
# Defined as a preprocessor macro in Lexical.xs to ensure the Perl and XS are kept in sync
my $METHOD_LEXICAL = xs_signature();

# accessors for the debug flags - note there is one for Perl ($DEBUG) and one defined
# in the XS (METHOD_LEXICAL_DEBUG). The accessors ensure that the two are kept in sync
sub _get_debug()   { $DEBUG }
sub _set_debug($)  { xs_set_debug($DEBUG = shift || 0) }

# This logs method installations/uninstallations
sub _debug {
    my ($class, $action, $fqname) = @_;
    carp "$class: $action $fqname";
}

# return true if $ref ISA $class - works with non-references, unblessed references and objects
sub _isa($$) {
    my ($ref, $class) = @_;
    return Scalar::Util::blessed(ref) ? $ref->isa($class) : ref($ref) eq $class;
}

# given a fully-qualified subroutine name (e.g. Foo::Bar::baz) load the module (Foo::Bar)
sub _load($) {
    my $fqname = shift;
    my ($module, $subname) = fqname($fqname);

    eval "require $module";

    if ($@) {
        no strict 'refs';
        # don't raise an error if the package is declared in an already-loaded file
        confess "Can't load $module for subroutine $fqname: $@" unless (%{"$module\::"});
    }
}

# install one or more lexical methods in the current scope
#
# import() has to keep track of two things:
#
# 1) $installed keeps track of *all* currently active lexical methods so that Lexical.xs
#    can track them without needing to know the subclass of Method::Lexical that installed them
# 2) $class_data keeps track of which subs have been installed by this class (which may be a subclass of
#    Method::Lexical) in this scope, so that they can be unimported with "no MyPragma (...)"

sub import {
    my $class = shift;
    my %bindings = ((@_ == 1) && _isa($_[0], 'HASH')) ? %{shift()} : @_; # hash or hashref

    return unless (%bindings);

    my $autoload = delete $bindings{-autoload};
    my $debug = delete $bindings{-debug};
    my $hints = my_hints;
    my $caller = ccstash();
    my $installed;

    if (defined $debug) {
        my $old_debug = _get_debug();
        if ($debug != $old_debug) {
            _set_debug($debug);
            on_scope_end { _set_debug($old_debug) };
        }
    }

    if (new_scope($METHOD_LEXICAL)) {
        my $top_level = 0;
        my $temp = $hints->{$METHOD_LEXICAL};

        if ($temp) {
            # the hash is cloned to ensure that inner/nested scopes don't clobber/contaminate
            # outer/previous scopes with their new bindings. Likewise, unimport installs
            # a new hash to ensure that previous bindings aren't clobbered e.g.
            #
            #   {
            #        package Foo;
            #
            #        use Method::Lexical bar => sub { ... };
            #
            #        Foo->new->bar();
            #
            #        no Method::Lexical; # don't clobber the bindings associated with the previous method call
            #   }

            $installed = $hints->{$METHOD_LEXICAL} = { %$temp }; # clone
        } else {
            $top_level = 1;
            $installed = $hints->{$METHOD_LEXICAL} = {}; # create

            # disable Method::Lexical altogether when we leave the top-level scope in which it was enabled
            on_scope_end \&xs_leave;

            # disable/re-enable check hooks before/after require
            on_require \&xs_leave, \&xs_enter;

            xs_enter();
        }
    } else {
        $installed = $hints->{$METHOD_LEXICAL}; # augment
    }

    # Note: the class-specific data is stored under "Method::Lexical($subclass)" rather than
    # $subclass. The subclass might well have its own uses for $^H{$subclass}, so we keep
    # our mitts off it
    #
    # Also, the unadorned class name can't be used as a key if $METHOD_LEXICAL is 'Method::Lexical' (which
    # it is) as the two uses conflict with and clobber each other

    my $subclass = "$METHOD_LEXICAL($class)";
    my $class_data;

    # never use $class as the identifier for new_scope() here - see above
    if (new_scope($subclass)) {
        my $temp = $hints->{$subclass};

        $class_data = $hints->{$subclass} = $temp ? { %$temp } : {}; # clone/create
    } else {
        $class_data = $hints->{$subclass}; # augment
    }

    for my $name (keys %bindings) {
        my $sub = $bindings{$name};

        # normalize bindings
        unless (_isa($sub, 'CODE')) {
            my $_autoload = $sub =~ s{^\+}{}; # autoload this sub's package
            my $subname = fqname($sub); # XXX watch out for fqname returning a list

            if ($_autoload || $autoload) {
                _load($subname);
            }

            $sub = do {
                no strict 'refs';
                *{$subname}{CODE}
            } || confess "Can't find subroutine for target $name: '$subname'";
        }

        my $fqname = fqname($name, $caller);

        if ($DEBUG) {
            if (exists $installed->{$fqname}) {
                $class->_debug('redefining', $fqname);
            } else {
                $class->_debug('creating', $fqname);
            }
        }

        $installed->{$fqname} = $sub;
        $class_data->{$fqname} = $sub;
    }
}

# uninstall one or more lexical subs from the current scope
sub unimport {
    my $class = shift;
    my $hints = my_hints;
    my $subclass = "$METHOD_LEXICAL($class)";
    my $class_data;

    return unless (($^H & 0x20000) && ($class_data = $hints->{$subclass}));

    my $caller = ccstash();
    my @subs = @_ ? (map { scalar(fqname($_, $caller)) } @_) : keys(%$class_data);
    my $installed = $hints->{$METHOD_LEXICAL};
    my $new_installed = { %$installed }; # clone
    my $deleted = 0;

    for my $fqname (@subs) {
        my $sub = $class_data->{$fqname};

        if ($sub) { # the coderef of the method this subclass installed
            # if the current sub ($installed->{$fqname}) is the sub this module installed ($class_data->{$fqname})
            if (Scalar::Util::refaddr($sub) == Scalar::Util::refaddr($installed->{$fqname})) {
                $class->_debug('unimporting', $fqname) if ($DEBUG);

                # what import adds, unimport taketh away
                delete $new_installed->{$fqname};
                delete $class_data->{$fqname};

                ++$deleted;
            } else {
                carp "$class: attempt to unimport a shadowed lexical method: $fqname";
            }
        } else {
            carp "$class: attempt to unimport an undefined lexical method: $fqname";
        }
    }

    if ($deleted) {
        $hints->{$METHOD_LEXICAL} = $new_installed;
    }
}

1;

__END__