File Coverage

blib/lib/Attribute/Method.pm

Criterion	Covered	Total	%
statement	67	67	100.0
branch	4	4	100.0
condition	2	3	66.6
subroutine	19	19	100.0
pod	0	1	0.0
total	92	94	97.8

package Attribute::Method;

use warnings;
use strict;
use Attribute::Handlers;
use B::Deparse;

our $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)/g;

my $dp        = Attribute::Method::_Deparse->new('-l');
my $dppack;
my %sigil2ref = (
    '$' => \undef,
    '@' => [],
    '%' => {},
);

sub import {
    my ( $class, @vars ) = @_;
    my $pkg = caller();
    push @vars, '$self';
    for my $var (@vars) {
        my $sigil = substr( $var, 0, 1, '' );
        no strict 'refs';
        *{ $pkg . '::' . $var } = $sigil2ref{$sigil};
    }
}

sub UNIVERSAL::Method : ATTR(RAWDATA) {
    my ( $pkg, $sym, $ref, undef, $args ) = @_;
    $dppack = $pkg;
    my $src = $dp->coderef2text($ref);
    if ($args) {
        $src =~ s/\{/{\nmy \$self = shift; my ($args) = \@_;\n/;
    }
    else {
        $src =~ s/\{/{\nmy \$self = shift;\n/;
    }
    no warnings 'redefine';
    my $sub_name = *{$sym}{NAME};
    eval qq{ package $pkg; sub $sub_name $src };
}

package
 Attribute::Method::_Deparse;

BEGIN { our @ISA = 'B::Deparse' }

sub maybe_qualify {
    my $ret = SUPER::maybe_qualify{@_};
    my ($pack,$name) = $ret =~ /(.*)::(.+)/;
    length $pack && $pack eq $dppack and return $name;
    $ret;
}

"Rosebud"; # for MARCEL's sake, not 1 -- dankogai

__END__