File Coverage

blib/lib/Class/Superclasses.pm

Criterion	Covered	Total	%
statement	107	107	100.0
branch	40	40	100.0
condition	5	5	100.0
subroutine	16	16	100.0
pod	3	3	100.0
total	171	171	100.0

package Class::Superclasses;

# ABSTRACT: Find all (direct) superclasses of a class

use strict;
use warnings;

use List::Util qw(first);
use PPI;

our $VERSION = '0.09';

sub new{
    my ($class,$doc) = @_,
    my $self         = {};

    bless $self,$class;

    $self->document($doc);

    return $self;
}

sub superclasses{
    my ($self) = @_;
    return wantarray ? @{$self->{super}} : $self->{super};
}

sub document{
    my ($self,$doc) = @_;

    if(defined $doc){
        $self->{document} = $doc;
        $self->{super}    = $self->_find_super($doc);
    }

    return $self;
}

sub _find_super{
    my ($self,$doc) = @_;

    my $ppi    = PPI::Document->new($doc) or die $!;
    my $varref = $ppi->find('PPI::Statement::Variable');
    my @vars   = ();

    if($varref){
        @vars    = $self->_get_isa_values($varref);
    }

    my $baseref  = $ppi->find('PPI::Statement::Include') || [];
    my @includes = qw(base parent);
    my @base     = $self->_get_include_values([grep{my $i = $_->module; grep{ $_ eq $i }@includes }@$baseref]);

    my @moose;
    my @moose_like_modules = qw(Moose Moo Mouse Mo);
    my $is_moose;

    for my $base_class ( @{$baseref} ) {
        if ( first{ $base_class->module eq $_ }@moose_like_modules ) {

            for my $stmt ( @{ $ppi->find('PPI::Statement') } ) {
                push @moose, $self->_get_moose_values( $stmt );
            }
        }
    }

    return [@vars, @base, @moose];
}

sub _get_moose_values{
    my ($self,$elem) = @_;

    my @parents;

    return if $elem->schild(0)->content ne 'extends';

    if ( $elem->find_any('PPI::Statement::Expression') ) {
        push @parents, $self->_parse_expression( $elem );
    }
    elsif ( $elem->find_any('PPI::Token::QuoteLike::Words') ) {
        push @parents, $self->_parse_quotelike( $elem );
    }
    elsif( $elem->find( \&_any_quotes ) ){
        push @parents, $self->_parse_quotes( $elem );
    }

    return @parents;
}

sub _get_include_values{
    my ($self, $baseref) = @_;
    my @parents;

    BASE:
    for my $base( @{$baseref} ){
        my @tmp_array;

        if( $base->find_any('PPI::Statement::Expression') ){
            push @tmp_array, $self->_parse_expression( $base );
        }
        elsif( $base->find_any('PPI::Token::QuoteLike::Words') ){
            push @tmp_array, $self->_parse_quotelike( $base );
        }
        elsif( $base->find( \&_any_quotes ) ){
            push @tmp_array, $self->_parse_quotes( $base );
        }

        if ( $base->module eq 'parent' ) {
            @tmp_array = grep{ $_ ne '-norequire' }@tmp_array;
        }

        push @parents, @tmp_array;
    }

    return @parents;
}

sub _any_quotes{
    my ($parent,$elem) = @_;

    $parent eq $elem->parent and (
        $elem->isa( 'PPI::Token::Quote::Double' ) or
        $elem->isa( 'PPI::Token::Quote::Single' )
    );
}

sub _get_isa_values{
    my ($self,$varref) = @_;
    my @parents;

    for my $variable ( @{ $varref || [] } ) {
        my @children = $variable->children();

        if( grep{$_->content eq '@ISA'}@children ) {
            if( $variable->find_any('PPI::Token::QuoteLike::Words') ) {
                push @parents, $self->_parse_quotelike($variable);
            }
            elsif( $variable->find_any('PPI::Statement::Expression') ) {
                push @parents, $self->_parse_expression($variable);
            }
        }
    }

    return @parents;
}

sub _parse_expression {
    my ($self, $variable) = @_;

    my $ref = $variable->find( 'PPI::Statement::Expression' );
    my @parents;

    for my $expression ( @{$ref} ) {
        for my $element( $expression->children ){
            if( $element->class =~ /^PPI::Token::Quote::/ ) {
                push @parents, $element->string;
            }
        }
    }

    return @parents;
}

sub _parse_quotes{
    my ($self,$variable,$type) = @_;

    my @parents;

    for my $element( $variable->children ){
        my ($type) = $element->class =~ /PPI::Token::Quote::([^:]+)$/;

        next unless $type;

        my $value  = $element->string;
        push @parents, $value;
    }

    return @parents;
}

sub _parse_quotelike{
    my ($self,$variable) = @_;

    my $words         = ($variable->find('PPI::Token::QuoteLike::Words'))[0]->[0];
    my $operator      = $words->{operator};
    my $section_type  = $words->{sections}->[0]->{type};
    my ($left,$right) = split //, $section_type;
    (my $value        = $words->content) =~ s~$operator\Q$left\E(.*)\Q$right\E~$1~;
    my @parents       = split /\s+/, $value;

    return @parents;
}


1;

__END__