File Coverage

blib/lib/CPANfile/Parse/PPI.pm

Criterion	Covered	Total	%
statement	99	100	99.0
branch	52	58	89.6
condition	11	12	91.6
subroutine	12	12	100.0
pod	1	1	100.0
total	175	183	95.6

package CPANfile::Parse::PPI;

# ABSTRACT: Parse Is with PPI

use strict;
use warnings;

our $VERSION = '0.06'; # VERSION

use Carp qw(carp croak);
use List::Util qw(first any);
use Moo;
use PPI;

my $strict;

has meta => (
    is      => 'ro',
    default => sub { +{} },
    isa     => sub {
        die if 'HASH' ne ref $_[0];
    }
);

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


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

    my ($meta, @modules) = _parse( $file_or_code );

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

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

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

    my $doc = PPI::Document->new( $file_or_code );

    # 'feature' and 'on' are handled separately
    my @bindings = qw(
        mirror osname
        requires recommends conflicts suggests
        test_requires author_requires configure_requires build_requires
    );

    my $requires = $doc->find(
        sub {
            $_[1]->isa('PPI::Token::Word') and do {
                my $content = $_[1]->content;
                first { $content eq $_ } @bindings;
             }
        }
    );

    return if !$requires;

    my @modules;
    my $meta = {};

    REQUIRED:
    for my $required ( @{ $requires || [] } ) {

        # 'mirror' can be an attribute for "requires" as well as a keyword
        # _scan_attrs should have removed all 'mirrors' that are used as
        # an attribute for 'requires'. So skip those PPI nodes...
        next REQUIRED if !$required;


        my $value = $required->snext_sibling;

        my $type  = $required->content;
        my %on_feature = (
            on      => '',
            feature => '',
        );

        if ( $type eq 'mirror' or $type eq 'osname' ) {
            push @{ $meta->{$type} }, $value->content if $value;
        }

        if ( -1 != index $type, '_' ) {
            (my $stage, $type) = split /_/, $type, 2;
            $stage = 'develop' if $stage eq 'author';
            $on_feature{on} = $stage;
        }

        my %attr = _scan_attrs( $required, $type );

        next REQUIRED if !$value;

        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 $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_feature) = $parent_node->find_first(
                    sub {
                        # need to create token var because 'any' messes up $_
                        my $token = $_[1];
                        $token->isa('PPI::Token::Word')
                            && (
                            any { $token->content eq $_ }
                            (qw{on feature})
                            );
                    }
                );
                if ($on_feature) {
                    my $word = $on_feature->snext_sibling;
                    my $condition
                        = $word->can('string')
                        ? $word->string
                        : $word->content;
                    $on_feature{ $on_feature->content } = $condition;
                    last PARENT;

                }
                else {
                    next 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;
            last SIBLING if !$value;

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

            last SIBLING;
        }

        push @modules, {
            name    => $prereq,
            version => $version,
            type    => $type,
            stage   => $on_feature{on},
            feature => $on_feature{feature},
            %attr,
        };
    }

    return $meta, @modules;
}

sub _scan_attrs {
    my ($required, $type) = @_;

    return if $type ne 'requires' && $type ne 'recommends';

    my $sibling = $required->snext_sibling;

    my %attr;
    my @to_delete;
    my $delete;

    while ( $sibling ) {
        my $content = $sibling->content;
        if ( $content eq 'mirror' or $content eq 'dist' ) {
            $delete = 1;
            my $value_node = $sibling->snext_sibling->snext_sibling;
            $attr{$content} = $value_node->can('string') ?
                $value_node->string :
                $value_node->content;
        }

        push @to_delete, $sibling if $delete;
        $sibling = $sibling->snext_sibling;
    }

    $_->remove for @to_delete;

    return %attr;
}

1;

__END__