view release on metacpan or  search on metacpan

lib/Method/Lexical.pm  view on Meta::CPAN

    # 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__

=head1 NAME

Method::Lexical - private methods and lexical method overrides

=head1 SYNOPSIS

    package MyPragma;

    use base qw(Method::Lexical);

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

=cut

=pod

    #!/usr/bin/env perl