File Coverage

blib/lib/Pugs/Emitter/Grammar/Perl5.pm

Criterion	Covered	Total	%
statement	9	52	17.3
branch	0	28	0.0
condition	0	17	0.0
subroutine	3	5	60.0
pod	1	1	100.0
total	13	103	12.6

package Pugs::Emitter::Grammar::Perl5;

our $VERSION = '0.28';

#use Smart::Comments;
use strict;
use warnings;
use Pugs::Emitter::Rule::Perl5::Ratchet;

# for safe mode
sub _prune_actions {
    my ($ast) = @_;
    while (my ($key, $node) = each %$ast) {
        next if $key =~ /^_/ or !ref $node;
        #warn $key;
        if ($key eq 'closure') {
            #die "Found closures!";
            next if ref $node ne 'HASH';
            my $code = $node->{closure};
            if ($code and !ref $code and $code =~ /\w+/) {
                die "ERROR: code blocks not allowed in safe mode: \"$code\"\n";
            }
        }
        if (ref $node) {
            my $ref = ref $node;
            if ($ref eq 'HASH') {
                _prune_actions($node);
            } elsif ($ref eq 'ARRAY') {
                for my $child (@$node) {
                    if (ref $child and ref $child eq 'HASH') {
                        _prune_actions($child);
                    }
                }
            }
        }
    }
}

sub emit {
    my $ast = shift;
    my $opts = shift;
    $opts ||= {};
    ## $ast
    my ($name, $stmts) = each %$ast;
    my $p5_methods = '';
    ### $name
    for my $stmt (@$stmts) {
        my $regex = $stmt->();
        my $type = $regex->{type};
        ## $regex
        if ($type eq 'block') {
            my $code = $regex->{value};
            if ($opts->{safe_mode} && $code =~ /\w+/) {
                die "ERROR: verbatim Perl 5 blocks not allowed in safe mode: \"$code\"\n";
            }
            $p5_methods .= <<"_EOC_";
# Code block from grammar spec
$code

_EOC_
            next;
        }
        ### struct: $regex->{name}
        ## regex AST: $regex->{ast}
        my $params = {};
        if ($type eq 'rule') {
            $params->{sigspace} = 1;
        }
        my $body;

        my $ast = $regex->{ast};
        if ($opts->{safe_mode}) {
            _prune_actions($ast);
        }

        if ($type eq 'regex') {
            $body = Pugs::Emitter::Rule::Perl5::emit(
                'Pugs::Grammar::Rule',
                $ast,
            )
        } else {
            $body = Pugs::Emitter::Rule::Perl5::Ratchet::emit(
                'Pugs::Grammar::Rule',
                $ast,
                $params,
            );
        }
        $body =~ s/^/    /gm;
        $p5_methods .= <<_EOC_;
# $regex->{type} $regex->{name}
*$regex->{name} =
$body;

_EOC_
    }
    # bootstrap the regex parser itself:
    my $prefix = $name eq 'Pugs::Grammar::Rule' ?
        "#" : '';
    return <<"_EOC_";
package $name;

${prefix}use base 'Pugs::Grammar::Base';

use Pugs::Runtime::Match;
use Pugs::Runtime::Regex;
use Pugs::Runtime::Tracer ();

$p5_methods

1;
_EOC_
}

1;
__END__