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__
=head1 NAME
Pugs::Emitter::Grammar::Perl5 - Perl 5 emitter for grammar ASTs
=head1 SYNOPSIS
use Pugs::Compiler::Grammar;
use Pugs::Emitter::Grammar::Perl5;
my $ast = Pugs::Grammar::Rule->grammar(q{
grammar MyLang;
token def {
<type> <?ws> <var_list> <?ws>? ';'
}
token type { int | float | double | char }
token var_list { <ident> <?ws>? [ ',' <?ws>? <ident> ]* }
})->();
my $perl5 = Pugs::Emitter::Grammar::Perl5::emit($ast);
print $perl5;
=head1 FUNCTIONS
=over
=item C<< $perl5 = Pugs::Emitter::Grammar::Perl5::emit($ast) >>
Generate Perl 5 source code from the grammar AST returned
by L<Pugs::Grammar::Rule>'s grammar parser.
=back
=head1 AUTHOR
The Pugs contributors E<lt>perl6-compiler@perl.orgE<gt>.
=head1 COPYRIGHT
Copyright (c) 2007 by Agent Zhang (E<lt>agentzh@agentzh.orgE<gt>) and others.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=head1 SEE ALSO
L<Pugs::Compiler::Grammar>, L<compile_p6grammar.pl>.