#!/usr/bin/perl

use warnings;
use strict;


# Operators currently supported.
my %Operators = (
    '+' => sub { @_ = getsymbolval(@_); my $n=0; $n+=$_ foreach @_; $n
+  },
    '-' => sub { @_ = getsymbolval(@_); my $n=shift; $n-=$_ foreach @_
+; $n  },
    '*' => sub { @_ = getsymbolval(@_); my $n= shift; $n*=$_ foreach @
+_; $n  },
    '/' => sub { @_ = getsymbolval(@_); my $n=shift; $n/=$_ foreach @_
+; $n  },
    '^' => sub { @_ = getsymbolval(@_); my $n=shift; $n = $n ** shift;
+ $n; },
    '=' => sub { no strict; my ($n,$v)=@_;  ${'Expression::Evaluate::'
+.$n} = getsymbolval($v)},

);



{

    print "Enter an expession..\n";
    my $exp = <STDIN>;
    chomp($exp);
    last if $exp=~/^quit$/;

    my $result = parse_expression($exp) ;
    $result = '' unless $result;    # Silence warning for undefined.
    print "Result: $result\n";        

    redo;
}



# Subs ########################################
sub parse_expression {
    my $exp = shift;
    my @tokens = ();
    # Pad out ops with spaces.
    $exp=~s/(\s*[\(\)\-\>\<=\+\*\/\^])\s*/ $1 /g;
    
    # Get tokens
    push @tokens, $1 while $exp=~/\G\s*"(.*?)"/gc or $exp=~/\G\s*'(.*?
+)'/gc or $exp=~/\G\s*(\S+)/gc;
    

    if (@tokens == 1 && $tokens[0]=~/^\w+$/){
        no strict;
        return getsymbolval($tokens[0]);
    }
    # Find any parens. 
    my (@lp,@rp) = ();
    for (my $p =0; $p < @tokens; $p++){
        if ($tokens[$p] eq '('){
            push @lp,$p;
        }elsif($tokens[$p] eq ')'){
            push @rp,$p;
        }
    }
    

    if ( @lp != @rp){
        warn "Mismatched parens in expression.";
        return;
    }

    
    my @temp = @tokens;
    for (my $i=0; $i < @rp; $i++){
         # Find the match in @lp that is < than.
         my @wanted;
         for (my $j = $#lp; $j >= 0 ; $j--){
            if ( defined $lp[$j] && $lp[$j] < $rp[$i] ){
                (undef,@wanted) = @tokens[ $lp[$j] ..  ($rp[$i] - 1 ) 
+] ;    
                @tokens[ $lp[$j] ..  ($rp[$i]) ] = \@wanted;
                push @temp, @wanted;
                $lp[$j] = $rp[$i] = undef;
                last;
            }
            
         }
    }

    return evaluate(\@tokens) ;

}

#################################################

sub evaluate {
    my $ops = shift;
    @$ops = grep { defined $_ } @$ops;
    foreach my $op (@$ops){
        if (ref $op eq 'ARRAY'){
            $op  = evaluate($op);
        }
    }

    # Process tokens right to left so assign propagates. (a = b = c = 
+3)
    my %pops = ();
    for (my $i=$#{$ops}; $i>=0; $i--){
        if ( index (" + - * / ^ = ", $ops->[$i]) > -1 ){
            push @{$pops{ $ops->[$i]}}, $i;
        }
    }

    # Order by precedence.
    my @ordered =  map { @{$pops{$_}} } grep { defined $pops{$_} } qw(
+ ^ * / + - =);
    
    while(my $i = shift @ordered ){
        my $op = [@$ops[ $i, $i-1,$i+1]];
        splice @{$ops}, $i - 1, 3 , $op;
        @ordered = map { $_ > $i ? $_ - 2 : $_} @ordered;
    }
    my $operator = shift @$ops;
    $operator = evaluate($operator) if ref $operator eq 'ARRAY';
    if (defined $operator){
        if (defined $Operators{$operator}){
            $ops = $Operators{$operator}->(@$ops);
        }elsif($operator && @$ops ){
            warn "Invalid expressions";
            warn "$operator:\n".Dumper($ops);
            return;
        }else{
            return $operator;
        }
    }
    
    return $ops;

}

#################################################
sub getsymbolval{
    no strict;
    my @syms = @_;
    foreach my $symbol (@syms){
        if ($symbol=~/^\D+$/){
            $symbol = ${'Expression::Evaluate::'.$symbol};
        }
    }
    wantarray ? @syms : $syms[0];    
}
[download]