File Coverage

blib/lib/Module/ExtractUse.pm

Criterion	Covered	Total	%
statement	127	161	78.8
branch	40	56	71.4
condition	15	23	65.2
subroutine	21	31	67.7
pod	21	21	100.0
total	224	292	76.7

package Module::ExtractUse;

use strict;
use warnings;
use 5.008;

use Pod::Strip;
use Parse::RecDescent 1.967009;
use Module::ExtractUse::Grammar;
use Carp;
our $VERSION = '0.343';

# ABSTRACT: Find out what modules are used

#$::RD_TRACE=1;
#$::RD_HINT=1;



sub new {
    my $class=shift;
    return bless {
        found=>{},
        files=>0,
    },$class;
}


# Regular expression to detect eval
#  On newer perl, you can use named capture groups and (?&name) for recursive regex
#  However, it requires perl newer than 5.008 declared as requirement in this module
my $re_block;
$re_block = qr {
    ( # eval BLOCK, corresponding to the group 10 in the entire regex
        \{
            ((?:
                (?> [^{}]+ )  # Non-braces without backtracking
            |
                (??{$re_block}) # Recurse to group 10
            )*)
        \}
    )
}xs;
my $re = qr{
    \G(.*?) # group 1
    eval
    (?:
        (?:\s+
            (?:
                qq?\((.*?)\) # eval q(), group 2
                |
                qq?\[(.*?)\] # eval q[], group 3
                |
                qq?{(.*?)}   # eval q{}, group 4
                |
                qq?<(.*?)>   # eval q<>, group 5
                |
                qq?(\S)(.*?)\6 # eval q'' or so, group 6, group 7
            )
        )
        |
        (?:\s*(?:
            (?:(['"])(.*?)\8) # eval '' or eval "", group 8, group 9
            |
            ( # eval BLOCK, group 10
                \{
                    ((?: # group 11
                        (?> [^{}]+ )  # Non-braces without backtracking
                    |
                        (??{$re_block}) # Recurse to group 10
                    )*)
                \}
            )
        ))
    )
}xs;

sub extract_use {
    my $self=shift;
    my $code_to_parse=shift;

    my $podless;
    my $pod_parser=Pod::Strip->new;
    $pod_parser->output_string(\$podless);
    $pod_parser->parse_characters(1) if $pod_parser->can('parse_characters');
    if (ref($code_to_parse) eq 'SCALAR') {
        $pod_parser->parse_string_document($$code_to_parse);
    }
    else {
        $pod_parser->parse_file($code_to_parse);
    }

    # Strip obvious comments.
    $podless =~ s/(^|[\};])\s*#.*$/$1/mg;

    # Strip __(DATA|END)__ sections.
    $podless =~ s/\n__(?:DATA|END)__\b.*$//s;

    my @statements;
    while($podless =~ /$re/gc) {
    # to keep parsing time short, split code in statements
    # (I know that this is not very exact, patches welcome!)
        my $pre = $1;
        my $eval = join('', grep { defined $_ } ($2, $3, $4, $5, $7, $9, $11));
        push @statements, map { [ 0, $_ ] } split(/;/, $pre); # non-eval context
        push @statements, map { [ 1, $_ ] } split(/;/, $eval); # eval context
    }
    push @statements, map { [ 0, $_ ] } split(/;/, substr($podless, pos($podless) || 0)); # non-eval context

    foreach my $statement_ (@statements) {
        my ($eval, $statement) = @$statement_;
        $statement=~s/\n+/ /gs;
        my $result;

        # now that we've got some code containing 'use' or 'require',
        # parse it! (using different entry point to save some more
        # time)
        my $type;
        if ($statement=~m/require_module|use_module|use_package_optimistically/) {
            $statement=~s/^(.*?)\b(\S+(?:require_module|use_module|use_package_optimistically)\([^)]*\))/$2/;
            next if $1 && $1 =~ /->\s*$/;
            eval {
                my $parser=Module::ExtractUse::Grammar->new();
                $result=$parser->token_module_runtime($statement);
            };
            $type = $statement =~ m/require/ ? 'require' : 'use';
        }
        elsif ($statement=~/\buse/) {
            $statement=~s/^(.*?)use\b/use/;
            next if $1 && $1 =~ /->\s*$/;
            eval {
                my $parser=Module::ExtractUse::Grammar->new();
                $result=$parser->token_use($statement.';');
            };
            $type = 'use';
        }
        elsif ($statement=~/\brequire/) {
            $statement=~s/^(.*?)require\b/require/s;
            next if $1 && $1 =~ /->\s*$/;
            eval {
                my $parser=Module::ExtractUse::Grammar->new();
                $result=$parser->token_require($statement.';');
            };
            $type = 'require';
        }
        elsif ($statement=~/\bno/) {
            $statement=~s/^(.*?)no\b/no/s;
            next if $1 && $1 =~ /->\s*$/;
            eval {
                my $parser=Module::ExtractUse::Grammar->new();
                $result=$parser->token_no($statement.';');
            };
            $type = 'no';
        }
        elsif ($statement=~m/load_class|try_load_class|load_first_existing_class|load_optional_class/) {
            $statement=~s/^(.*?)\b(\S+(?:load_class|try_load_class|load_first_existing_class|load_optional_class)\([^)]*\))/$2/;
            next if $1 && $1 =~ /->\s*$/;
            eval {
                my $parser=Module::ExtractUse::Grammar->new();
                $result = $parser->token_class_load($statement.';');
            };
            $type = 'require';
        }

        next unless $result;

        foreach (split(/\s+/,$result)) {
            $self->_add($_, $eval, $type) if($_);
        }
    }

    # increment file counter
    $self->_inc_files;

    return $self;
}



sub used {
    my $self=shift;
    my $key=shift;
    return $self->{found}{$key} if ($key);
    return $self->{found};
}


sub used_in_eval {
    my $self=shift;
    my $key=shift;
    return $self->{found_in_eval}{$key} if ($key);
    return $self->{found_in_eval};
}


sub used_out_of_eval {
    my $self=shift;
    my $key=shift;
    return $self->{found_not_in_eval}{$key} if ($key);
    return $self->{found_not_in_eval};
}


sub required {
    my $self=shift;
    my $key=shift;
    return $self->{require}{$key} if ($key);
    return $self->{require};
}


sub required_in_eval {
    my $self=shift;
    my $key=shift;
    return $self->{require_in_eval}{$key} if ($key);
    return $self->{require_in_eval};
}


sub required_out_of_eval {
    my $self=shift;
    my $key=shift;
    return $self->{require_not_in_eval}{$key} if ($key);
    return $self->{require_not_in_eval};
}


sub noed {
    my $self=shift;
    my $key=shift;
    return $self->{no}{$key} if ($key);
    return $self->{no};
}


sub noed_in_eval {
    my $self=shift;
    my $key=shift;
    return $self->{no_in_eval}{$key} if ($key);
    return $self->{no_in_eval};
}


sub noed_out_of_eval {
    my $self=shift;
    my $key=shift;
    return $self->{no_not_in_eval}{$key} if ($key);
    return $self->{no_not_in_eval};
}


sub string {
    my $self=shift;
    my $sep=shift || ' ';
    return join($sep,sort keys(%{$self->{found}}));
}


sub string_in_eval {
    my $self=shift;
    my $sep=shift || ' ';
    return join($sep,sort keys(%{$self->{found_in_eval}}));
}


sub string_out_of_eval {
    my $self=shift;
    my $sep=shift || ' ';
    return join($sep,sort keys(%{$self->{found_not_in_eval}}));
}


sub array {
    return keys(%{shift->{found}})
}


sub array_in_eval {
    return keys(%{shift->{found_in_eval}})
}


sub array_out_of_eval {
    return keys(%{shift->{found_not_in_eval}})
}


sub arrayref {
    my @a=shift->array;
    return \@a if @a;
    return;
}


sub arrayref_in_eval {
    my @a=shift->array_in_eval;
    return \@a if @a;
    return;
}


sub arrayref_out_of_eval {
    my @a=shift->array_out_of_eval;
    return \@a if @a;
    return;
}


sub files {
    return shift->{files};
}

# Internal Accessor Methods
sub _add {
    my $self=shift;
    my $found=shift;
    my $eval=shift;
    my $type=shift;
    $self->{found}{$found}++;
    $self->{$type}{$found}++;
    if ($eval) {
        $self->{found_in_eval}{$found}++;
        $self->{"${type}_in_eval"}{$found}++;
    } else {
        $self->{found_not_in_eval}{$found}++;
        $self->{"${type}_not_in_eval"}{$found}++;
    }
}

sub _found {
    return shift->{found}
}

sub _inc_files {
    shift->{files}++
}

1;

__END__