#!/usr/bin/perl -w

use strict;
use Parse::RecDescent;

my @STACK;

use MooX::Struct
    Program => [
        qw( @instructions ),
        evaluate => sub {
            my $self = shift;
            my $result;
            foreach my $instruction (@{ $self->instructions }) {
                $result = $instruction->evaluate;
            }
            return $result;
        },
        to_perl => sub {
            my $self = shift;
            join "\n", map { sprintf('%s;', $_->to_perl) } @{ $self->i
+nstructions };
        },
        to_javascript => sub {
            my $self = shift;
            join "\n", map { sprintf('%s;', $_->to_javascript) } @{ $s
+elf->instructions };
        },
    ],
    PrintStatement => [
        qw( $expression ),
        evaluate => sub {
            my $self = shift;
            print STDOUT $self->expression->evaluate, "\n";
        },
        to_perl => sub {
            my $self = shift;
            sprintf('print STDOUT %s, "\n"', $self->expression->to_per
+l);
        },
        to_javascript => sub {
            my $self = shift;
            sprintf('window.alert(%s)', $self->expression->to_javascri
+pt);
        },
    ],
    Assignment => [
        qw( $variable $expression ),
        evaluate => sub {
            my $self = shift;
            $self->variable->evaluate = $self->expression->evaluate;
        },
        to_perl => sub {
            my $self = shift;
            sprintf('%s = %s', $self->variable->to_perl, $self->expres
+sion->to_perl);
        },
        to_javascript => sub {
            my $self = shift;
            sprintf('%s = %s', $self->variable->to_javascript, $self->
+expression->to_javascript);
        },
    ],
    Expression => [
        qw( $op $lhs $rhs ),
        evaluate => sub {
            my $self = shift;
            my $op   = $self->op;
            my $sub  = eval qq{ sub { \$_[0] $op \$_[1] } };
            $sub->($self->lhs->evaluate, $self->rhs->evaluate);
        },
        to_perl => sub {
            my $self = shift;
            sprintf('(%s %s %s)', $self->lhs->to_perl, $self->op, $sel
+f->rhs->to_perl);
        },
        to_javascript => sub {
            my $self = shift;
            my $op   = $self->op;
            $op = '+' if $op eq '.';
            sprintf('(%s %s %s)', $self->lhs->to_javascript, $op, $sel
+f->rhs->to_javascript);
        },
    ],
    Literal => [
        qw( $value ),
        evaluate => sub { $_[0]->value },
    ],
    Integer  => [
        -extends => ['Literal'],
        to_perl => sub {
            my $self = shift;
            sprintf('%s', $self->value);
        },
        to_javascript => sub {
            my $self = shift;
            sprintf('%s', $self->value);
        },
    ],
    String   => [
        -extends => ['Literal'],
        to_perl => sub {
            my $self = shift;
            sprintf("'%s'", $self->value);
        },
        to_javascript => sub {
            my $self = shift;
            sprintf("'%s'", $self->value);
        },
    ],
    Variable => [
        qw( $name ),
        evaluate => sub :lvalue { $STACK[-1]{ $_[0]->name } },
        to_perl => sub {
            my $self = shift;
            sprintf('$%s', $self->name);
        },
        to_javascript => sub {
            my $self = shift;
            sprintf('%s', $self->name);
        },
    ],
;

sub _handle_expression {
    my (undef, $left, $op, $right) = @_;
    return Expression[$op, $left, $right];
}

sub _handle_program {
    return Program[@_];
}

sub _handle_assignment {
    return Assignment[@_];
}

sub _handle_print {
    return PrintStatement[@_];
}

sub _handle_integer {
    my (undef, $i) = @_;
    return Integer[$i];
}

sub _handle_variable {
    my (undef, $v) = @_;
    return Variable[$v];
}

sub _handle_string {
    my (undef, $s) = @_;
    $s =~ s/^'(.*)'$/$1/;
    return String[$s];
}

sub _handle_concatenation {
    my (undef, $left, $op, $right) = @_;
    return Expression['.', $left, $right];
}

$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an er
+ror
$::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c
+.
$::RD_HINT   = 1; # Give out hints to help fix problems.
# $::RD_TRACE  = 1; # Trace the whole thing

my $parser = Parse::RecDescent->new(<<'_EOGRAMMAR_');

# Terminals (macros that can't expand further)
#

startrule : instruction(s /;/) 
          { main::_handle_program($item[1]) }

instruction : print_instruction
            { $item[1] }
            | assign_instruction
            { $item[1] }
            | expression
            { $item[1] }

print_instruction  : /print/i expression 
                   { main::_handle_print($item{expression}) }
assign_instruction : VARIABLE "=" expression
                   { main::_handle_assignment($item{VARIABLE}, $item{e
+xpression}) }

expression : STRING '+' expression
           { main::_handle_concatenation(@item) }
           | term OP expression
           { main::_handle_expression(@item) }
           | term
           { $item[1] }

term: '(' expression ')' 
      { $item[2] }
      | INTEGER
      | STRING
      | VARIABLE

OP       : m([*/%+-])
INTEGER  : /[+-]?[0-9]*\.?[0-9]+/     # Signed integers
         { main::_handle_integer(@item) }
VARIABLE : /\w[a-z0-9_]*/i # Variable
         { main::_handle_variable(@item) }
STRING   : /'.*?'/
         { main::_handle_string(@item) }

_EOGRAMMAR_


my $parsed = $parser->startrule(<<'SCRIPT');

    x = (2+3)/(2*(7+3));
    print x;
    print 'Hello World';

SCRIPT

@STACK = {};

print $parsed->to_perl, "\n---\n";
print $parsed->to_javascript, "\n---\n";
$parsed->evaluate;
[download]