Method::Lexical - private methods and lexical method overrides

    package MyPragma;

    use base qw(Method::Lexical);

    sub import {
        shift->SUPER::import(
            'private'         => sub { ... },
            'UNIVERSAL::dump' => '+Data::Dump::pp'
        )
    }

    #!/usr/bin/env perl

    my $self = bless {};

    {
        use MyPragma;

        $self->private(); # OK
        $self->dump();    # OK
    }

    $self->private; # Can't locate object method "private" via package "main"
    $self->dump;    # Can't locate object method "dump" via package "main"

    use Method::Lexical
        foo              => sub { ... },         # anonymous sub value
        bar              => \&bar,               # code ref value
        new              => 'main::new',         # sub name value
        dump             => '+Data::Dump::dump', # autoload Data::Dump
       'UNIVERSAL::dump' => \&Data::Dump::dump,  # define an inherited method
       'UNIVERSAL::isa'  => \&my_isa,            # override an inherited method
      '-autoload'        => 1,                   # autoload modules for all subs passed by name
      '-debug'           => 1;                   # show diagnostic messages

    use Method::Lexical
         foo       => 'MyFoo::foo',
         bar       => 'MyBar::bar',
         baz       => 'MyBaz::baz',
       '-autoload' => 1;
or

    use MyFoo;
    use MyBaz;

    use Method::Lexical
         foo =>  'MyFoo::foo',
         bar => '+MyBar::bar', # autoload MyBar
         baz =>  'MyBaz::baz';

    use Method::Lexical
        AUTOLOAD             => sub { ... },
       'UNIVERSAL::AUTOLOAD' => \&autoload;

    use Method::Lexical
         foo    => \&foo,
         bar    => sub { ... },
       '-debug' => 1;

    package Universal::Dump;

    use base qw(Method::Lexical);

    sub import { shift->SUPER::import('UNIVERSAL::dump' => '+Data::Dump::dump') }

    1;

    #!/usr/bin/env perl

    use CGI;

    {
        use Universal::Dump;

        say CGI->new->dump; # OK
    }

    eval { CGI->new->dump };
    warn $@; # Can't locate object method "dump" via package "CGI"

    use Method::Lexical foo => \&foo;

    my $self = bless {};

    {
        use Method::Lexical
             bar             => sub { ... },
            'UNIVERSAL::baz' => sub { ... };

        $self->foo(); # OK
        $self->bar(); # OK
        $self->baz(); # OK

        no Method::Lexical qw(foo);

        eval { $self->foo() };
        warn $@; # Can't locate object method "foo" via package "main"

        $self->bar(); # OK
        $self->baz(); # OK

        no Method::Lexical;

        eval { $self->bar() };
        warn $@; # Can't locate object method "bar" via package "main"

        eval { $self->baz() };
        warn $@; # Can't locate object method "baz" via package "main"
    }

    $self->foo(); # OK

    {
        use MyPragma qw(foo bar baz);

        use Method::Lexical quux => \&quux;

        $self->foo();  # OK
        $self->quux(); # OK

        no MyPragma qw(foo); # unimports foo
        no MyPragma;         # unimports bar and baz
        no Method::Lexical;  # unimports quux
    }

    sub public {
        my $self = shift;
        $self->private(); # not a private method; compiled as an ordinary (public) method call
    }

    use Method::Lexical private => sub { ... };

    use Method::Lexical private => sub { ... };

    sub public {
        my $self = shift;
        $self->private(); # OK
    }

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(croak carp);
use Devel::Pragma qw(ccstash fqname my_hints new_scope on_require);
use XSLoader;

our $VERSION = '0.23';
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) }
sub start_trace() { set_debug(1) } # undocumented
sub stop_trace()  { set_debug(0) } # undocumented

# 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;
}

# croak with the name of this package prefixed
sub pcroak($$) {
    my ($class, $msg) = @_;
    croak "$class: $msg";
}

# split "Foo::Bar::baz" into the stash (Foo::Bar) and the name (baz)
sub _split($) {
    my @split = $_[0] =~ /^(.*)::([^:]+)$/; 
    return wantarray ? @split : \@split;
}

# load a perl module
sub load($$) {
    my ($class, $symbol) = @_;
    my $module = _split($symbol)->[0];
    eval "require $module";
    $class->pcroak("can't load $module: $@") if ($@);
}

# 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, %bindings) = @_;

    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')) {
            $sub = do {
                $class->load($sub) if (($sub =~ s/^\+//) || $autoload);
                no strict 'refs';
                *{$sub}{CODE}
            } || $class->pcroak("can't find subroutine: '$sub'");
        }

        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__