package CPANfile::Parse::PPI;

# ABSTRACT: Parse I<cpanfile>s 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__

=pod

=encoding UTF-8

=head1 NAME

CPANfile::Parse::PPI - Parse I<cpanfile>s with PPI

=head1 VERSION

version 0.06

=head1 SYNOPSIS

    use v5.24;
    use CPANfile::Parse::PPI;
    
    my $path     = '/path/to/cpanfile';
    my $cpanfile = CPANfile::Parse::PPI->new( $path );
    
    # or
    # my $cpanfile = CPANfile::Parse::PPI->new( \$content );
    
    for my $module ( $cpanfile->modules->@* ) {
        my $stage   = $module->{stage}   ? " on $module->{stage}"            : '';
        my $feature = $module->{feature} ? " for feature $module->{feature}" : '';

        say sprintf "%s is %s",
             $module->{name}, $module->{type}, $stage, $feature;
    }

=begin pod_coverage

=head2 BUILDARGS

=head2 import

=end pod_coverage

=head1 METHODS

=head2 new

    my $path     = '/path/to/cpanfile';
    my $cpanfile = CPANfile::Parse::PPI->new( $path );
    
    # or
    my $content  = <<'CPANFILE';
    requires "CPANfile::Parse::PPI" => 3.6;';
    on build => sub {
        recommends "Dist::Zilla" => 4.0;
        requires "Test2" => 2.311;
    }
    feature 'sqlite', "SQLite Support" => sub {
        requires DBD::SQLite
    }
    CPANFILE

    my $cpanfile = CPANfile::Parse::PPI->new( \$content );

=head1 ATTRIBUTES

=head2 meta

Returns information about mirrors and OS name - if given in the cpanfile

=head2 modules

Returns a list of modules mentioned in the cpanfile ("perl" is skipped).
Each element is a hashref with these keys:

=over 4

=item * name

=item * version

=item * type

=item * stage

=item * feature

=back

    use CPANfile::Parse::PPI;
    use Data::Printer;

    my $required = 'requires "CPANfile::Parse::PPI" => 3.6;';
    my $cpanfile = CPANfile::Parse::PPI->new( \$required );
    
    my $modules = $cpanfile->modules;
    p $modules;
    
    __DATA__
    [
        [0] {
            name      "CPANfile::Parse::PPI",
            stage     "",
            type      "requires",
            version   3.6
        }
    ]

=head1 LIMITATIONS

As this is a static parser, this module cannot handle dynamic
code like

    for my $module (qw/
        IO::All
        Zydeco::Lite::App
    /) {
        requires $module, '0';
    }

This module warns when the required "module" doesn't look like
a package name.

You can make it die when you pass C<-strict> to the module
when you load it:

    use CPANfile::Parse::PPI -strict;
    use Data::Printer;

    my $required = do { local $/; <DATA> };
    my $cpanfile = CPANfile::Parse::PPI->new( \$required );
    
    my $modules = $cpanfile->modules;
    
    __DATA__
    for my $module (qw/
        IO::All
        Zydeco::Lite::App
    /) {
        requires $module, '0';
    }

=head1 AUTHOR

Renee Baecker <reneeb@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2020 by Renee Baecker.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut
