File Coverage

blib/lib/Tangerine.pm

Criterion	Covered	Total	%
statement	92	95	96.8
branch	30	40	75.0
condition	16	43	37.2
subroutine	18	21	85.7
pod	8	10	80.0
total	164	209	78.4

package Tangerine;
$Tangerine::VERSION = '0.19';
# ABSTRACT: Examine perl files and report dependency metadata
use 5.010;
use strict;
use warnings;
use utf8;
use PPI;
use List::MoreUtils qw(none);
use Scalar::Util qw(blessed);
use Tangerine::Hook;
use Tangerine::Occurence;
use Tangerine::Utils qw(accessor addoccurence);

sub new {
    my $class = shift;
    my %args = @_;
    bless {
        _file => $args{file},
        _mode => $args{mode} // 'all',
        _hooks => {
            package => [ qw/package/ ],
            compile => [ qw/use list prefixedlist if inline moduleload
                moduleruntime mooselike testrequires tests xxx/ ],
            runtime => [ qw/require/ ],
        },
        _package => {},
        _compile => {},
        _runtime => {},
    }, $class
}

sub file { accessor _file => @_ }
sub mode { accessor _mode => @_ }

sub package { accessor _package => @_ }
sub compile { accessor _compile => @_ }
sub runtime { accessor _runtime => @_ }
# For pre-0.15 compatibility
sub provides { accessor _package => @_ }
sub requires { accessor _runtime => @_ }
sub uses { accessor _compile => @_ }

sub run {
    my $self = shift;
    return 0 unless -r $self->file;
    $self->mode('all')
        unless $self->mode =~
            /^(a(ll)?|p(ackage|rov)?|compile|d(ep)?|r(untime|eq)?|u(se)?)$/;
    my $document = PPI::Document->new($self->file, readonly => 1);
    return 0 unless $document;
    my $statements = $document->find('Statement') or return 1;
    my @hooks;
    for my $type (qw(package compile runtime)) {
        for my $hname (@{$self->{_hooks}->{$type}}) {
            my $hook = "Tangerine::hook::$hname";
            eval "require $hook";
            push @hooks, $hook->new(type => $type);
        }
    }
    @hooks = grep {
            if ($self->mode =~ /^a/o ||
                $_->type eq 'package' && $self->mode =~ /^p/o ||
                $_->type eq 'compile' && $self->mode =~ /^[cdu]/o ||
                $_->type eq 'runtime' && $self->mode =~ /^[dr]/o) {
                $_
            }
        } @hooks;
    my $children;
    my $forcetype;
    STATEMENT: for my $statement (@$statements) {
        $children //= [ $statement->schildren ];
        if ($children->[1] &&
            ($children->[1] eq ',' || $children->[1] eq '=>')) {
            undef $children;
            next STATEMENT
        }
        for my $hook (@hooks) {
            if (my $data = $hook->run($children)) {
                my $modules = $data->modules;
                for my $k (keys %$modules) {
                    if ($k !~ m/^[a-z_][a-z0-9_]*(::[a-z0-9_]+)*(::)?$/io ||
                        $k =~ m/^__[A-Z]+__$/o) {
                        delete $modules->{$k};
                        next
                    }
                    if (my ($class) = ($k =~ /^(.+)::$/o)) {
                        $modules->{$class} = $modules->{$k}
                            unless exists $modules->{$class};
                        delete $modules->{$k};
                        $k = $class
                    }
                    $modules->{$k}->line($statement->line_number);
                }
                my $type = $forcetype // $hook->type;
                if ($type eq 'package') {
                    $self->package(addoccurence($self->package, $modules));
                } elsif ($type eq 'compile') {
                    $self->compile(addoccurence($self->compile, $modules));
                } elsif ($type eq 'runtime') {
                    $self->runtime(addoccurence($self->runtime, $modules));
                }
                if (@{$data->hooks}) {
                    for my $newhook (@{$data->hooks}) {
                        next if ($newhook->type eq 'package') && ($self->mode =~ /^[dcru]/o);
                        next if ($newhook->type eq 'runtime') && ($self->mode =~ /^[pcu]/o);
                        next if ($newhook->type eq 'compile') && ($self->mode =~ /^[pr]/o);
                        push @hooks, $newhook
                            if none {
                                blessed($newhook) eq blessed($_) &&
                                $newhook->type eq $_->type
                            } @hooks;
                    }
                }
                if (@{$data->children}) {
                    $children = $data->children;
                    $forcetype = $data->type;
                    redo STATEMENT;
                }
            }
        }
        undef $children,
        undef $forcetype;
    }
    1;
}

1;

__END__