File Coverage

blib/lib/Perl/PrereqScanner/Lite.pm

Criterion	Covered	Total	%
statement	28	181	15.4
branch	3	90	3.3
condition	0	54	0.0
subroutine	8	15	53.3
pod	6	7	85.7
total	45	347	12.9

package Perl::PrereqScanner::Lite;
use 5.008005;
use strict;
use warnings;
use Carp ();
use Compiler::Lexer;
use CPAN::Meta::Requirements;
use Perl::PrereqScanner::Lite::Constants;

our $VERSION = "0.27";

sub new {
    my ($class, $opt) = @_;

    my $lexer;
    if ($opt->{no_prereq}) {
        $lexer = Compiler::Lexer->new({verbose => 1}),
    }
    else {
        $lexer = Compiler::Lexer->new(),
    }

    my $extra_scanners = [];
    if (my $scanner_names = $opt->{extra_scanners}) {
        if (ref $scanner_names eq 'ARRAY') {
            for my $scanner_name (@$scanner_names) {
                my $extra_scanner;
                if (substr($scanner_name, 0, 1) eq '+') {
                    $extra_scanner = substr $scanner_name, 1;
                }
                else {
                    $extra_scanner = "Perl::PrereqScanner::Lite::Scanner::$scanner_name";
                }

                eval "require $extra_scanner"; ## no critic
                push @$extra_scanners, $extra_scanner;
            }
        } else {
            Carp::croak "'extra_scanners' option must be array reference";
        }
    }

    bless {
        lexer          => $lexer,
        extra_scanners => $extra_scanners,
        module_reqs    => CPAN::Meta::Requirements->new,
    }, $class;
}

sub add_extra_scanner {
    my ($self, $scanner_name) = @_;

    my $extra_scanner;
    if (substr($scanner_name, 0, 1) eq '+') {
        $extra_scanner = substr $scanner_name, 1;
    }
    else {
        $extra_scanner = "Perl::PrereqScanner::Lite::Scanner::$scanner_name";
    }

    eval "require $extra_scanner"; ## no critic
    push @{$self->{extra_scanners}}, $extra_scanner;
}

sub scan_string {
    my ($self, $string) = @_;

    my $tokens = $self->{lexer}->tokenize($string);
    $self->_scan($tokens);
}

sub scan_file {
    my ($self, $file) = @_;

    open my $fh, '<', $file or die "Cannot open file: $file";
    my $script = do { local $/; <$fh>; };

    $self->scan_string($script);
}

sub scan_tokens {
    my ($self, $tokens) = @_;
    $self->_scan($tokens);
}

sub scan_module {
    my ($self, $module) = @_;

    require Module::Path;

    if (defined(my $path = Module::Path::module_path($module))) {
        return $self->scan_file($path);
    }
}

sub _scan {
    my ($self, $tokens) = @_;

    my $module_name    = '';
    my $module_version = 0;

    my $not_decl_module_name = '';

    my $is_in_reglist   = 0;
    my $is_in_usedecl   = 0;
    my $is_in_reqdecl   = 0;
    my $is_inherited    = 0;
    my $is_in_list      = 0;
    my $is_version_decl = 0;
    my $is_aliased      = 0;
    my $is_prev_version = 0;
    my $is_prev_module_name = 0;

    my $does_garbage_exist = 0;
    my $does_use_lib_or_constant = 0;

    my $latest_prereq = '';

    TOP:
    for (my $i = 0; my $token = $tokens->[$i]; $i++) {
        my $token_type = $token->{type};

        # For require statement
        if ($token_type == REQUIRE_DECL || ($token_type == BUILTIN_FUNC && $token->{data} eq 'no')) {
            $is_in_reqdecl = 1;
            next;
        }
        if ($is_in_reqdecl) {
            # e.g.
            #   require Foo;
            if ($token_type == REQUIRED_NAME || $token_type == KEY) {
                $latest_prereq = $self->add_minimum($token->{data} => 0);

                $is_in_reqdecl = 0;
                next;
            }

            # e.g.
            #   require Foo::Bar;
            if ($token_type == NAMESPACE || $token_type == NAMESPACE_RESOLVER) {
                $module_name .= $token->{data};
                next;
            }

            # End of declare of require statement
            if ($token_type == SEMI_COLON) {
                if ($module_name) {
                    $latest_prereq = $self->add_minimum($module_name => 0);
                }

                $module_name   = '';
                $is_in_reqdecl = 0;
                next;
            }

            next;
        }

        # For use statement
        if ($token_type == USE_DECL) {
            $is_in_usedecl = 1;
            next;
        }
        if ($is_in_usedecl) {
            # e.g.
            #   use Foo;
            #   use parent qw/Foo/;
            #
            if ($token_type == USED_NAME || $token_type == IF_STMT) {
                # XXX                       ~~~~~~~~~~~~~~~~~~~~~~
                # Workaround for `use if` statement
                # It is a matter of Compiler::Lexer (maybe).
                #
                #   use if $] < 5.009_005, 'MRO::Compat';

                $module_name = $token->{data};

                if ($module_name eq 'lib' || $module_name eq 'constant') {
                    $latest_prereq = $self->add_minimum($module_name, 0);
                    $does_use_lib_or_constant = 1;
                }
                elsif ($module_name =~ /(?:base|parent)/) {
                    $is_inherited = 1;
                }
                elsif ($module_name =~ 'aliased') {
                    $is_aliased = 1;
                }

                $is_prev_module_name = 1;
                next;
            }

            # End of declare of use statement
            if ($token_type == SEMI_COLON || $token_type == LEFT_BRACE || $token_type == LEFT_BRACKET) {
                if ($module_name && !$does_use_lib_or_constant) {
                    $latest_prereq = $self->add_minimum($module_name => $module_version);
                }

                $module_name    = '';
                $module_version = 0;
                $is_in_reglist  = 0;
                $is_inherited   = 0;
                $is_in_list     = 0;
                $is_in_usedecl  = 0;
                $is_aliased     = 0;
                $does_garbage_exist  = 0;
                $is_prev_module_name = 0;
                $does_use_lib_or_constant = 0;

                next;
            }

            # e.g.
            #   use Foo::Bar;
            if ($token_type == NAMESPACE || $token_type == NAMESPACE_RESOLVER) {
                $module_name .= $token->{data};
                $is_prev_module_name = 1;
                next;
            }

            # Section for parent/base
            if ($is_inherited) {
                # For qw() notation
                # e.g.
                #   use parent qw/Foo Bar/;
                if ($token_type == REG_LIST) {
                    $is_in_reglist = 1;
                }
                elsif ($is_in_reglist) {
                    if ($token_type == REG_EXP) {
                        for my $_module_name (split /\s+/, $token->{data}) {
                            $latest_prereq = $self->add_minimum($_module_name => 0);
                        }
                        $is_in_reglist = 0;
                    }
                }

                # For simply list
                # e.g.
                #   use parent ('Foo' 'Bar');
                elsif ($token_type == LEFT_PAREN) {
                    $is_in_list = 1;
                }
                elsif ($token_type == RIGHT_PAREN) {
                    $is_in_list = 0;
                }
                elsif ($is_in_list) {
                    if ($token_type == STRING || $token_type == RAW_STRING) {
                        $latest_prereq = $self->add_minimum($token->{data} => 0);
                    }
                }

                # For string
                # e.g.
                #   use parent "Foo"
                elsif ($token_type == STRING || $token_type == RAW_STRING) {
                    $latest_prereq = $self->add_minimum($token->{data} => 0);
                }

                $is_prev_module_name = 0;
                next;
            }

            if ($token_type == DOUBLE || $token_type == INT || $token_type == VERSION_STRING) {
                if (!$module_name) {
                    if (!$does_garbage_exist) {
                        # For perl version
                        # e.g.
                        #   use 5.012;
                        my $perl_version = $token->{data};
                        $latest_prereq = $self->add_minimum('perl' => $perl_version);
                        $is_in_usedecl = 0;
                    }
                }
                elsif($is_prev_module_name) {
                    # For module version
                    # e.g.
                    #   use Foo::Bar 0.0.1;'
                    #   use Foo::Bar v0.0.1;
                    #   use Foo::Bar 0.0_1;
                    $module_version = $token->{data};
                }

                $is_prev_module_name = 0;
                $is_prev_version = 1;
                next;
            }

            if ($is_aliased) {
                if ($token_type == STRING || $token_type == RAW_STRING) {
                    $latest_prereq = $self->add_minimum($token->{data} => 0);
                    $is_aliased = 0;
                }
                next;
            }

            if (($is_prev_module_name || $is_prev_version) && $token_type == LEFT_PAREN) {
                my $left_paren_num = 1;
                for ($i++; $token = $tokens->[$i]; $i++) { # skip content that is surrounded by parens
                    $token_type = $token->{type};

                    if ($token_type == LEFT_PAREN) {
                        $left_paren_num++;
                    }
                    elsif ($token_type == RIGHT_PAREN) {
                        last if --$left_paren_num <= 0;
                    }
                }
                next;
            }

            if ($token_type != WHITESPACE) {
                $does_garbage_exist  = 1;
                $is_prev_module_name = 0;
                $is_prev_version = 0;
            }
            next;
        }

        for my $extra_scanner (@{$self->{extra_scanners}}) {
            if ($extra_scanner->scan($self, $token, $token_type)) {
                next TOP;
            }
        }

        if ($token_type == COMMENT && $token->{data} =~ /\A##\s*no prereq\Z/) {
            $self->{module_reqs}->clear_requirement($latest_prereq);
            next;
        }
    }

    return $self->{module_reqs};
}

sub add_minimum {
    my ($self, $module_name, $module_version) = @_;

    if ($module_name) {
        $self->{module_reqs}->add_minimum($module_name => $module_version);
    }

    return $module_name;
}

1;
__END__