File Coverage

lib/Petal/CodeGenerator.pm

Criterion	Covered	Total	%
statement	294	307	95.7
branch	51	74	68.9
condition	10	26	38.4
subroutine	32	33	96.9
pod	0	9	0.0
total	387	449	86.1

package Petal::CodeGenerator::Decode;
use strict;
use warnings;
use base qw /MKDoc::XML::Decode/;


##
# $class->process ($xml);
# -----------------------
# Expands the entities ' " > < and &
# into their ascii equivalents.
##
sub process
{
    (@_ == 2) or warn "MKDoc::XML::Encode::process() should be called with two arguments";

    my $self = shift;
    my $data = join '', @_;
    $data    =~ s/&(#?[0-9A-Za-z]+)\\;/$self->entity_to_char ($1)/eg;

    return $data;
}


# ------------------------------------------------------------------
# Petal::CodeGenerator - Generates Perl code from canonical syntax
# ------------------------------------------------------------------
# Author: Jean-Michel Hiver
# Description: This class parses a template in 'canonical syntax'
# (referred as the 'UGLY SYNTAX' in the manual) and generates Perl
# code that can be turned into a subroutine using eval().
# ------------------------------------------------------------------
package Petal::CodeGenerator;
use MKDoc::XML::Decode;
use strict;
use warnings;
use Carp;

our $PI_RE = '^<\?(?:\s|\r|\n)*(attr|include|var|if|condition|else|repeat|loop|foreach|for|eval|endeval|end|defslot).*?\?>$';
use vars qw /$petal_object $tokens $variables @code $indentLevel $token_name %token_hash $token $my_array/;


sub indent_increment
{
    my $class = shift;
    $Petal::CodeGenerator::indentLevel++;
}


sub indent_decrement
{
    my $class = shift;
    $Petal::CodeGenerator::indentLevel--;
}


sub indent
{
    my $class = shift;
    return $Petal::CodeGenerator::indentLevel;
}


# these _xxx_res primitives have been contributed by Fergal Daly
# they speed up string construction a little bit
sub _init_res
{
    return '$res = ""';
}


sub _add_res
{
    my $class = shift;
    my $thing = shift;
    return qq{\$res .= $thing};
}


sub _final_res
{
    return q{$res};
}


sub _get_res
{
    return q{$res};
}


sub add_code
{
    my $class = shift;
    push(@code, "    " x $class->indent() . shift);
}


sub comp_expr
{
    my $self = shift;
    my $expr = shift;
    return "\$hash->get ('$expr')";
}


sub comp_expr_encoded
{
    my $self = shift;
    my $expr = shift;
    return "\$hash->get_encoded ('$expr')";
}


# $class->code_header();
# ----------------------
# This generates the beginning of the anonymous subroutine.
sub code_header
{
    my $class = shift;
    $class->add_code("\$VAR1 = sub {");
    $class->indent_increment();
    $class->add_code("my \$hash = shift;");
    $class->add_code("my ".$class->_init_res.";");
    $class->add_code('local $^W = 0;') unless $Petal::WARN_UNINIT;
}


# $class->code_footer();
# ----------------------
# This generates the tail of the anonymous subroutine
sub code_footer
{
    my $class = shift;
    $class->add_code("return ". $class->_final_res() .";");
    $class->indent_decrement();
    $class->add_code("};");
}


# $class->process ($data_ref, $petal_object);
# -------------------------------------------
# This (too big) subroutine converts the canonicalized template
# data into Perl code which is ready to be evaled and executed.
sub process
{
    my $class = shift;
    my $data_ref = shift;

    local $petal_object = shift || die "$class::" . "process: \$petal_object was not defined";

    local $tokens = $class->_tokenize ($data_ref);
    local $variables = {};
    local @code = ();
    local $Petal::CodeGenerator::indentLevel = 0;
    local $token_name = undef;
    local %token_hash = ();
    local $token = undef;
    local $my_array = {};

    $class->code_header();

    foreach $token (@{$tokens})
    {
        if ($token =~ /$PI_RE/s)
        {
            ($token_name) = $token =~ /$PI_RE/s;
            my @atts1 = $token =~ /(\S+)\=\"(.*?)\"/gos;
            my @atts2 = $token =~ /(\S+)\=\'(.*?)\'/gos;
            %token_hash = (@atts1, @atts2);
            foreach my $key (%token_hash)
            {
                $token_hash{$key} = $class->_decode_backslash_semicolon ($token_hash{$key})
                    if (defined $token_hash{$key});
            }

          CASE:
            for ($token_name)
            {
                /^attr$/      and do { $class->_attr;    last CASE };
                /^include$/   and do { $class->_include; last CASE };
                /^var$/       and do { $class->_var;     last CASE };
                /^if$/        and do { $class->_if;      last CASE };
                /^condition$/ and do { $class->_if;      last CASE };
                /^else$/      and do { $class->_else;    last CASE };
                /^repeat$/    and do { $class->_for;     last CASE };
                /^loop$/      and do { $class->_for;     last CASE };
                /^foreach$/   and do { $class->_for;     last CASE };
                /^for$/       and do { $class->_for;     last CASE };
                /^eval$/      and do { $class->_eval;    last CASE };
                /^endeval$/   and do { $class->_endeval; last CASE };
                /^defslot$/   and do { $class->_defslot; last CASE };

                /^end$/ and do
                {
                    my $idt = $class->indent();
                    delete $my_array->{$idt};
                    $class->indent_decrement();
                    $class->add_code("};");
                    last CASE;
                };
            }
        }
        else
        {
            my $string = quotemeta ($token);
#            $string =~ s/\@/\\\@/gsm;
#            $string =~ s/\$/\\\$/gsm;
#            $string =~ s/\n/\\n/gsm;
#            $string =~ s/\n//gsm;
#            $string =~ s/\"/\\\"/gsm;
            $class->add_code($class->_add_res( '"' . $string . '";'));
        }
    }

    $class->code_footer();
    return join "\n", @code;
}


# $class->_include;
# -----------------
# process a  file
sub _include
{
    my $class = shift;
    my $file  = $token_hash{file};
    my $path  = $petal_object->_include_compute_path ($file);
    my $lang  = $petal_object->language();
    $class->add_code ($class->_add_res ("do {"));
    $class->indent_increment();

    my $included_from = $petal_object->_file();
    $included_from =~ s/\#.*$//;

    $class->add_code ("do {");
    $class->indent_increment();

    $class->add_code ("my \$new_hash = \$hash->new();");
    $class->add_code ("\$new_hash->{__included_from__} = '$included_from';");

    (defined $lang and $lang) ?
        $class->add_code ("my \$res = eval { Petal->new (file => '$path', lang => '$lang')->process (\$new_hash) };") :
        $class->add_code ("my \$res = eval { Petal->new ('$path')->process (\$new_hash) };");

    $class->add_code ("if (\$@) { confess(\$@); }") if $Petal::ERROR_ON_INCLUDE_ERROR;

    $class->add_code ("\$res = \"\" if (defined \$\@ and \$\@);");
    $class->add_code ("\$res;");
    $class->indent_decrement();
    $class->add_code ("} || '';");

    $class->indent_decrement();
    $class->add_code ("};");
}


# $class->_defslot;
# ---------------------
# process a  statement
sub _defslot
{
    my $class = shift;
    my $variable = $token_hash{name} or
        confess "Cannot parse $token : 'name' attribute is not defined";

    (defined $variable and $variable) or
        confess "Cannot parse $token : 'name' attribute is not defined";

    # set the variable in the $variables hash
    my $tmp = $variable;
    $tmp =~ s/\..*//;
    $variables->{$tmp} = 1;

    $variable =~ s/\'/\\\'/g;

    $class->add_code ("do {");
    $class->indent_increment();

    $class->add_code ("my \$tmp = undef;");
    $class->add_code ("\$hash->{__included_from__} && do {");
    $class->indent_increment();

    $class->add_code ("my \$path = \$hash->{__included_from__} . '#$variable';");
    $class->add_code ("my \$new_hash = \$hash->new();");
    $class->add_code ("delete \$new_hash->{__included_from__};");

    my $lang  = $petal_object->language();
    (defined $lang and $lang) ?
        $class->add_code ("\$tmp = eval { Petal->new (file => \$path, lang => '$lang')->process (\$new_hash) };") :
        $class->add_code ("\$tmp = eval { Petal->new (\$path)->process (\$new_hash) };");

    $class->add_code ("if (\$@) { confess(\$@); }") if $Petal::ERROR_ON_INCLUDE_ERROR;

    $class->indent_decrement();
    $class->add_code ("};");

    $class->add_code ("if (\$tmp) {");
    $class->indent_increment();

    $class->add_code ( $class->_add_res ("\$tmp") );
    $class->indent_decrement();

    $class->add_code ( "} else {" );
    $class->indent_increment();
}


# $class->_var;
# -------------
# process a  statement
sub _var
{
    my $class = shift;
    my $variable = $token_hash{name} or
        confess "Cannot parse $token : 'name' attribute is not defined";

    (defined $variable and $variable) or
        confess "Cannot parse $token : 'name' attribute is not defined";

    # set the variable in the $variables hash
    my $tmp = $variable;
    $tmp =~ s/\..*//;
    $variables->{$tmp} = 1;

    $variable =~ s/\'/\\\'/g;
    $class->add_code ( $class->_add_res (('do {')) );
    $class->indent_increment();
    $class->add_code ('my $res = ' . $class->comp_expr_encoded ($variable) . ';');
    $class->add_code ('(defined $res) ? $res : "";');
    $class->indent_decrement();
    $class->add_code ('};');
}


# $class->_if;
# ------------
# process a  statement
sub _if
{
    my $class = shift;
    my $variable = $token_hash{name} or
        confess "Cannot parse $token : 'name' attribute is not defined";

    (defined $variable and $variable) or
        confess "Cannot parse $token : 'name' attribute is not defined";

    # set the variable in the $variables hash
    my $tmp = $variable;
    $tmp =~ s/\..*//;
    $variables->{$tmp} = 1;

    $variable =~ s/\'/\\\'/g;
    $class->add_code("if (".$class->comp_expr($variable).") {");
    $class->indent_increment();
}


# $class->_eval;
# -------------------
# process a  statement
sub _eval
{
    my $class = shift;
    $class->add_code($class->_add_res("eval {"));
    $class->indent_increment();
    $class->add_code("my " . $class->_init_res() .";");
    $class->add_code("local %SIG;");
    $class->add_code("\$SIG{__DIE__} = sub { \$\@ = shift };");
}


# $class->_endeval;
# -----------------
# process a  statement
sub _endeval
{
    my $class = shift;
    my $variable = $token_hash{'errormsg'} or
       confess "Cannot parse $token : 'errormsg' attribute is not defined";

    $class->add_code("return " . $class->_get_res() . ";");
    $class->indent_decrement();
    $class->add_code("} || '';");

    $class->add_code("if (defined \$\@ and \$\@) {");
    $class->indent_increment();

    $variable =~ s/\&/&/g;
    $variable =~ s/\
    $variable =~ s/\>/>/g;
    $variable =~ s/\"/"/g;
    $variable = quotemeta ($variable);
    $class->add_code($class->_add_res("\"$variable\";"));
    $class->indent_decrement();
    $class->add_code("}");
}


# $class->_attr;
# --------------
# process a  statement
sub _attr
{
    my $class = shift;
    my $attribute = $token_hash{name} or
        confess "Cannot parse $token : 'name' attribute is not defined";

    my $variable = $token_hash{value} or
        confess "Cannot parse $token : 'value' attribute is not defined";

    (defined $variable and $variable) or
        confess "Cannot parse $token : 'value' attribute is not defined";

    # set the variable in the $variables hash
    my $tmp = $variable;
    $tmp =~ s/\..*//;
    $variables->{$tmp} = 1;

    $variable =~ s/\'/\\\'/g;
    $class->add_code('{');
    $class->indent_increment();
    $class->add_code ("my \$value = " . $class->comp_expr_encoded($variable) . ";");
    $class->add_code ("if (defined(\$value)) {");
    # $class->add_code ("if (defined(\$value) and length(\$value)) {");
    $class->indent_increment();
    $class->add_code ($class->_add_res (qq {"$attribute=\\"\$value\\""}) );
    $class->indent_decrement();
    $class->add_code ("}");
    $class->indent_decrement();
    $class->add_code ("}");
}


# $class->_else;
# --------------
# process a  statement
sub _else
{
    my $class = shift;
    $class->indent_decrement();
    $class->add_code("}");
    $class->add_code("else {");
    $class->indent_increment();
}


# $class->_for;
# -------------
# process a  statement
sub _for
{
    my $class = shift;
    my $variable = $token_hash{name} or
    confess "Cannot parse $token : 'name' attribute is not defined";

    (defined $variable and $variable) or
    confess "Cannot parse $token : 'name' attribute is not defined";

    $variable =~ s/^\s+//;
    my $as;
    ($as, $variable) = split /\s+/, $variable, 2;

    (defined $as and defined $variable) or
        confess "Cannot parse $token : loop name not specified";

    # set the variable in the $variables hash
    my $tmp = $variable;
    $tmp =~ s/\..*//;
    $variables->{$tmp} = 1;

    my $idt = $class->indent();
    $variable =~ s/\'/\\\'/g;
    unless (defined $my_array->{$idt})
    {
        $class->add_code("my \$array = ".$class->comp_expr($variable).";");
        $class->add_code(
            qq{die 'tried to repeat but $variable gave no array reference'}
            . qq{ unless defined \$array and ref \$array eq 'ARRAY';}
        );
        $class->add_code("my \@array = \@\$array;");
        $my_array->{$idt} = 1;
    }
    else
    {
        #$class->add_code("\@array = \@{".$class->comp_expr($variable)."};");
        $class->add_code("\$array = ".$class->comp_expr($variable).";");
        $class->add_code(
            qq{die 'tried to repeat but $variable gave no array reference'}
            . qq{ unless defined \$array and ref \$array eq 'ARRAY';}
        );
        $class->add_code("\@array = \@\$array;");
    }


    $class->add_code ("for (my \$i=0; \$i < \@array; \$i++) {");
    $class->indent_increment();
    $class->add_code ("my \$hash   = \$hash->new();");

    # compute various might-be-useful variables
    $class->add_code ("my \$number = \$i + 1;");
    $class->add_code ("my \$odd    = \$number % 2;");
    $class->add_code ("my \$even   = \$i % 2;");
    $class->add_code ("my \$start  = (\$i == 0);");
    $class->add_code ("my \$end    = (\$i == \$#array);");
    $class->add_code ("my \$inner  = (\$i and \$i < \@array);");

    # backwards compatibility
    $class->add_code ("\$hash->{__count__}    = \$number;");
    $class->add_code ("\$hash->{__is_first__} = \$start;");
    $class->add_code ("\$hash->{__is_last__}  = \$end;");
    $class->add_code ("\$hash->{__is_inner__} = \$inner;");
    $class->add_code ("\$hash->{__even__}     = \$even;");
    $class->add_code ("\$hash->{__odd__}      = \$odd;");

    # new repeat style object
    $class->add_code ("\$hash->{repeat} = {");
    $class->indent_increment();
    $class->add_code ("index  => \$i,");
    $class->add_code ("number => \$number,");
    $class->add_code ("even   => \$even,");
    $class->add_code ("odd    => \$odd,");
    $class->add_code ("start  => \$start,");
    $class->add_code ("end    => \$end,");
    $class->add_code ("inner  => \$inner,");
    $class->add_code ("};");
    $class->indent_decrement();

    $class->add_code ("\$hash->{'$as'} = \$array[\$i];");
}


# $class->_tokenize ($data_ref);
# ------------------------------
# Returns the data to process as a list of tokens:
# ( 'some text', '<% a_tag %>', 'some more text', '<% end-a_tag %>' etc.
sub _tokenize
{
    my $self = shift;
    my $data_ref = shift;

    my @tags  = $$data_ref =~ /(<\?.*?\?>)/gs;
    my @split = split /(?:<\?.*?\?>)/s, $$data_ref;

    my $tokens = [];
    while (@split)
    {
        push @{$tokens}, shift (@split);
        push @{$tokens}, shift (@tags) if (@tags);
    }
    push @{$tokens}, (@tags);
    return $tokens;
}


sub _decode_backslash_semicolon
{
    my $class = shift;
    my $data  = shift;

    my $decode = new Petal::CodeGenerator::Decode ('xml');
    return $decode->process ($data);
}


1;