The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Template::Flute::Expression;

use strict;
use warnings;

use Scalar::Util qw/reftype/;

=head1 NAME

Template::Flute::Expression - Parser for expressions

=head1 CONSTRUCTOR

=head2 new

Creates Template::Flute::Expression object.

    $expr = Template::Flute::Expression->new('!username');

Possible expressions are:

=over 4

=item username

Evaluates to value C<username>.

=item !username

Reverse.

=item foo.bar

Evaluates to value C<foo.bar>, e.g. $values->{foo}->{bar}.

=item !foo.bar

Reverse.

=item foo|bar

Evaluates to value C<foo> or value C<bar>.

=item foo&bar

Evaluates to value C<foo> and value C<bar>.

=item foo|bar

Evaluates to value C<foo> or reverse of value C<bar>.

=item foo&bar

Evaluates to value C<foo> and reverse of value C<bar>.

=back
    
=cut

use Parse::RecDescent;

sub new {
    my ($class, $self);

    $class = shift;
    $self = {expression => shift};
    bless $self, $class;

    $self->{_rd} = Parse::RecDescent->new(q{
<autoaction: { [@item] } >

var : /\w[a-z0-9_]*/

dottedvar : var '.' var

andor : term /[|&]/ term

notvar: '!' var

notdottedvar: '!' dottedvar

term: var | notvar | dottedvar | notdottedvar

expression : andor | dottedvar | notdottedvar | var | notvar
});

    return $self;
};

=head1 METHODS

=head2 evaluate 

    $expr->evaluate({foo => 'bar'});

Evaluates the expression with a hash reference of values
and returns the result.

=cut

sub evaluate {
    my ($self, $value_ref) = @_;
    my ($tree);
    
    $self->{values} = $value_ref;
    $tree = $self->_build();
    $self->_walk($tree);
}

sub _build {
    my ($self) = @_;
    my ($tree);

    $tree = $self->{_rd}->expression($self->{expression});

    return $tree;
}

sub _walk {
    my ($self, $tree) = @_;

    if ($tree->[0] eq 'expression') {
        return $self->_walk($tree->[1]);
    }
    elsif ($tree->[0] eq 'term') {
        return $self->_walk($tree->[1]);
    }
    elsif ($tree->[0] eq 'andor') {
        my ($val_one, $val_two, $op);

        $val_one = $self->_walk($tree->[1]);
        $op = $tree->[2];
        $val_two = $self->_walk($tree->[3]);

        if ($op eq '&') {
            return $val_one && $val_two;
        }
        elsif ($op eq '|') {
            return $val_one || $val_two;
        }
    }
    elsif ($tree->[0] eq 'notvar') {
        # do reverse
        if ($self->_walk($tree->[2])) {
            return 0;
        }
        return 1;
    }
    elsif ($tree->[0] eq 'var') {
        # just the value
        return $self->_value($tree->[1]);
    }
    elsif ($tree->[0] eq 'dottedvar') {
        # get value for current level
        my $values_ref = $self->_value($tree->[1]->[1]);
        my $reftype = reftype($values_ref);

        if ($reftype && $reftype eq 'HASH') {
            return $self->_value($tree->[3]->[1], $values_ref);
        }
        else {
            return 0;
        }
    }
    elsif ($tree->[0] eq 'notdottedvar') {
        # do reverse
        if ($self->_walk($tree->[2])) {
            return 0;
        }
        return 1;
    }
    elsif ($tree->[0]) {
        die "Invalid operation: ", $tree->[0];
    }
}

sub _value {
    my ($self, $name, $values_ref) = @_;
    my ($value);

    if (! ref($values_ref)) {
        $values_ref = $self->{values};
    }
    
    if (exists($values_ref->{$name}) 
	&& defined($values_ref->{$name})
	&& $values_ref->{$name} =~ /\S/) {
	$value = $values_ref->{$name};
    }
    else {
	$value = '';
    }

    return $value;
}

1;