File Coverage

blib/lib/Module/CPANfile/Writer.pm

Criterion	Covered	Total	%
statement	63	64	98.4
branch	18	26	69.2
condition	8	8	100.0
subroutine	13	13	100.0
pod	4	4	100.0
total	106	115	92.1

package Module::CPANfile::Writer;
use strict;
use warnings;
use Carp qw/croak/;

use Babble::Match;
use PPR;

our $VERSION = "0.01";

sub new {
    my ($class, $f) = @_;
    croak('Usage: Module::CPANfile::Writer->new($f)') unless defined $f;

    my $src;
    if (ref $f) {
        croak('Not a SCALAR reference') unless ref $f eq 'SCALAR';

        $src = $$f;
    } else {
        $src = do {
            open my $fh, '<', $f or die $!;
            local $/; <$fh>;
        };
    }

    return bless {
        src     => $src,
        prereqs => [],
    }, $class;
}

sub src {
    my $self = shift;

    my $top = Babble::Match->new(top_rule => 'Document', text => $self->{src});
    $top->each_match_within('Call' => [
        [ relationship => '(?:requires|recommends|suggests|conflicts)' ],
        '(?&PerlOWS) \(? (?&PerlOWS)',
        [ module => '(?: (?&PerlString) | (?&PerlBareword) )' ],
        [ arg1_before => '(?&PerlOWS) (?: (?>(?&PerlComma)) (?&PerlOWS) )*' ],
        [ arg1 => '(?&PerlAssignment)?' ],
        '(?&PerlOWS) (?: (?>(?&PerlComma)) (?&PerlOWS) )*',
        [ args => '(?&PerlCommaList)?' ],
        '\)? (?&PerlOWS)',
    ] => sub {
        my ($m) = @_;
        my $relationship = $m->submatches->{relationship}->text;
        my $module = _perl_string_or_bareword($m->submatches->{module}->text);

        my $prereq = _find_prereq($self->{add_prereqs}, $module, $relationship) or return;

        my $version = $prereq->{version};
        if ($m->submatches->{arg1}->text eq '' ||            # no arguments except module name
            _args_num($m->submatches->{args}->text) % 2 == 1 # not specify module version but there are options
        ) {
            # requires 'A';
            # requires 'B', dist => '...';
            if ($version) {
                $m->submatches->{module}->transform_text(sub { s/$/, '$version'/ });
            }
        } else {
            # requires 'C', '0.01';
            if ($version) {
                $m->submatches->{arg1}->replace_text(qq{'$version'});
            } else {
                $m->submatches->{arg1}->replace_text('');
                $m->submatches->{arg1_before}->replace_text('');
            }
        }
    });

    return $top->text;
}

sub save {
    my ($self, $file) = @_;
    croak('Usage: $self->save($file)') unless defined $file;

    open my $fh, '>', $file or die $!;
    print {$fh} $self->src;
}

sub add_prereq {
    my ($self, $module, $version, %opts) = @_;
    croak('Usage: $self->prereq($module, [$version, relationship => $relationship])') unless defined $module;

    my $relationship = $opts{relationship} || 'requires';

    push @{$self->{add_prereqs}}, {
        module       => $module,
        version      => $version,
        relationship => $relationship,
    };
}

sub _find_prereq {
    my ($prereqs, $module, $relationship) = @_;

    for my $prereq (@$prereqs) {
        if ($prereq->{module} eq $module && $prereq->{relationship} eq $relationship) {
            return $prereq;
        }
    }

    return undef;
}

sub _perl_string_or_bareword {
    my ($s) = @_;

    if ($s =~ /\A (?&PerlString) \Z $PPR::GRAMMAR/x) {
        return eval $s;
    }

    # bareword
    return $s;
}

sub _args_num {
    my ($s) = @_;

    # count number of arguments from PerlCommaList
    return scalar grep defined, $s =~ m{
        \G (?: (?>(?&PerlComma)) (?&PerlOWS) )* ((?&PerlAssignment))
            $PPR::GRAMMAR
    }gcx;
}

1;
__END__