File Coverage

blib/lib/CPANfile/Parse/PPI.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	35	38	92.1
condition	6	6	100.0
subroutine	10	10	100.0
pod	1	1	100.0
total	115	118	97.4

package CPANfile::Parse::PPI;

# ABSTRACT: Parse Is with PPI

use strict;
use warnings;

use PPI;
use Moo;
use Carp qw(carp croak);

our $VERSION = '0.04';

my $strict;

has modules => (
    is  => 'ro',
    isa => sub {
        die if 'ARRAY' ne ref $_[0];
    }
);


sub BUILDARGS {
    my ($class, $file_or_code) = @_;

    my @modules = _parse( $file_or_code );

    return {
        modules => \@modules,
    };
}

sub import {
    $strict = 1 if grep{ $_ eq '-strict' }@_;
}

sub _parse {
    my ($file_or_code) = @_;

    my $doc = PPI::Document->new( $file_or_code );
    my $requires = $doc->find(
        sub {
            $_[1]->isa('PPI::Token::Word') and (
                $_[1]->content eq 'requires' ||
                $_[1]->content eq 'recommends'
             )
        }
    );

    return if !$requires;

    my @modules;

    REQUIRED:
    for my $required ( @{ $requires || [] } ) {
        my $value = $required->snext_sibling;

        my $type = $required->content;

        my $can_string = $value->can('string') ? 1 : 0;
        my $prereq     = $can_string ?
            $value->string :
            $value->content;

        next REQUIRED if $prereq eq 'perl';

        if (
            $value->isa('PPI::Token::Symbol') ||
            $prereq =~ m{\A[^A-Za-z]}
        ) {
            carp  'Cannot handle dynamic code' if !$strict;
            croak 'Cannot handle dynamic code' if $strict;

            next REQUIRED;
        }

        my $stage = '';

        my $parent_node = $value;

        PARENT:
        while ( 1 ) {
            $parent_node = $parent_node->parent;
            last PARENT if !$parent_node;
            last PARENT if $parent_node->isa('PPI::Document');

            if ( $parent_node->isa('PPI::Structure::Block') ) {
                $parent_node = $parent_node->parent;

                my ($on) = $parent_node->find_first( sub { $_[1]->isa('PPI::Token::Word') && $_[1]->content eq 'on' } );

                next PARENT if !$on;

                my $word = $on->snext_sibling;
                $stage = $word->can('string') ? $word->string : $word->content;

                last PARENT;
            }
        }

        my $version = '';
        my $sibling = $value->snext_sibling;
        SIBLING:
        while ( 1 ) {
            last SIBLING if !$sibling;

            do { $sibling = $sibling->snext_sibling; next SIBLING } if !$sibling->isa('PPI::Token::Operator');

            my $value = $sibling->snext_sibling;
            $version = $value->can('string') ? $value->string : $value->content;

            last SIBLING;
        }

        push @modules, {
            name    => $prereq,
            version => $version,
            type    => $type,
            stage   => $stage,
        };
    }

    return @modules;
}

1;

__END__