File Coverage

blib/lib/CCCP/AttributeInspector.pm

Criterion	Covered	Total	%
statement	12	83	14.4
branch	0	52	0.0
condition	0	13	0.0
subroutine	4	11	36.3
pod	4	4	100.0
total	20	163	12.2

package CCCP::AttributeInspector;

use strict;
use warnings;

our $VERSION = '0.01';

# singleton
my $pm = undef;

sub __pm_new {
    $pm ? $pm : ($pm = bless({},__PACKAGE__));
}

sub __internal_resolv {
    my ($obj,$class) = @_;

    return if exists $obj->{'__internal_resolv'}->{$class};

    no strict 'refs';
        $obj->{'__all_methods'}->{$class} = [grep {defined &{"${class}::$_"}} keys %{sprintf('%s::',$class)}];
        map {
            if (exists $obj->{$class}->{\&{"${class}::$_"}}) {
                $obj->{$class}->{$_} = delete $obj->{$class}->{\&{"${class}::$_"}};
            }
        } @{$obj->{'__all_methods'}->{$class}};
    use strict 'refs';

    $obj->{'__internal_resolv'}->{$class}++;

    return;
}

sub all_methods {
    my ($class) = @_;

    return unless $class;
    $class = ref $class if ref $class;

    my $obj = __PACKAGE__->__pm_new();

    return wantarray() ? () : [] unless exists $obj->{$class};

    $obj->__internal_resolv($class);

    return wantarray() ? @{$obj->{'__all_methods'}->{$class}} : $obj->{'__all_methods'}->{$class};
}

sub att_methods {
    my ($class,$att_list) = @_;

    return unless $class;
    $class = ref $class if ref $class;

    my $obj = __PACKAGE__->__pm_new();

    return wantarray() ? () : [] unless exists $obj->{$class};

    $obj->__internal_resolv($class);

    unless ($att_list) {
        return wantarray() ? keys %{$obj->{$class}} : [keys %{$obj->{$class}}];
    } elsif (ref $att_list eq 'HASH') {
        my @ret = grep {
            my $meth = $_;
            my $good = 1;
            foreach (keys %$att_list) {
                unless (exists $obj->{$class}->{$meth}->{$_} and $obj->{$class}->{$meth}->{$_} eq $att_list->{$_}) {
                    $good = 0;
                    last;
                };
            };
            $good;
        } keys %{$obj->{$class}};
        return wantarray() ? @ret : [@ret];
    } elsif (ref $att_list eq 'ARRAY') {
        my @ret = grep {
            my $meth = $_;
            my $good = 1;
            foreach (@$att_list) {
                unless (exists $obj->{$class}->{$meth}->{$_}) {
                    $good = 0;
                    last;
                };
            };
            $good;
        } keys %{$obj->{$class}};
        return wantarray() ? @ret : [@ret];
    };
}

sub get_attributes {
    my ($class,$method) = @_;

    return {} unless ($class and $method and not ref $method);
    $class = ref $class if ref $class;

    my $obj = __PACKAGE__->__pm_new();
    return {} unless (exists $obj->{$class});

    $obj->__internal_resolv($class);

    return exists $obj->{$class}->{$method} ? $obj->{$class}->{$method} : {};
}

sub packages {
    my $obj = __PACKAGE__->__pm_new();
    return wantarray() ? keys %$obj : [keys %$obj];
}

sub MODIFY_CODE_ATTRIBUTES {
    my ($class, $code, @attrs) = @_;
    return () unless @attrs;

    my $obj = __PACKAGE__->__pm_new();

    foreach (@attrs) {
        /(\w+)\((['"]?)/;
        my $quote = $2 || '';
        my ($attr_name,$undef,$attr_value) = $_ =~ /(\w+)(\($quote(.*)$quote\))?/;
        $obj->{$class}->{$code}->{$attr_name} = $attr_value || '';
    };

    return ();
}


1;
__END__