Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
PerlMonks  

Evaluate Expressions.

by shotgunefx (Parson)
on Sep 27, 2002 at 03:33 UTC ( #201113=snippet: print w/ replies, xml ) Need Help??

Description: Evaluate user supplied expressions. Handy when you don't trust your user data. (user supplied template,etc) Examples:
a = ( 4+(b=2) * (5.2) ) # Sets a to 14.4 and b to 2 returns 14.4 for the result of the entire expression.
a # returns 14.4
a= e || b # sets a to 2 if e undefined
a=b=c=d = int(10.5431) # Set a,b,c,d to 10
From what I understand, it's a little like a Lisp top level.
#!/usr/bin/perl

use warnings;
use strict;

# Operators currently supported.
# %Operators does double duty.
# It includes functions ie: int() and ops ie: a + b 
# The difference being that an op takes the form of  VAR1 OP VAR2
# and functions take the form of OP (EXPRESSION)

# You can add abritrary ops as long as the don't match a-zA-Z
# Functions can contain letters and numbers.

my $last_value= undef;
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)=@_; 
                    if ($n!~/^[a-zA-Z_]/){
                        warn "Attempt to assign to read-only variable.
+\n";
                        return;
                    }
                    ${'Expression::Evaluate::'.$n} = getsymbolval($v)
                },
    '==' => sub { no strict; my ($n,$v)=@_;  getsymbolval($n) == getsy
+mbolval($v)},
    '<' => sub { no strict; my ($n,$v)=@_; return getsymbolval($n) <ge
+tsymbolval($v)  },
    '<=' => sub { no strict; my ($n,$v)=@_; return getsymbolval($n) <=
+ getsymbolval($v)  },
    '>' => sub { no strict; my ($n,$v)=@_; return getsymbolval($n) > g
+etsymbolval($v)  },
    '>=' => sub { no strict; my ($n,$v)=@_; return getsymbolval($n) >=
+ getsymbolval($v)  },
    '&&' => sub { no strict; my ($n,$v)=@_; return  getsymbolval($n) &
+& getsymbolval($v)  },
    '||' => sub { no strict; my ($n,$v)=@_; return  getsymbolval($n) |
+| getsymbolval($v)  },
    '_' => sub {     # Concat
                    no strict;     
                    my ($n,$v)= getsymbolval(@_);
                    $n=~s/['"]$//; $v=~s/^['"]//;    #"
                    return $n.$v;
                },
    # Functions
    'int'    => sub { return int getsymbolval(shift) },
    'lc'    => sub { return lc getsymbolval(shift) },
    'uc'    => sub { return uc getsymbolval(shift) },
);

# Symbols are for predifined values...
my %symbols = (
    ':date'    => sub { scalar localtime},
    ':id'    => "lee_test",
    ':last' => sub { return $last_value },
);


{

    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 = ();
    # Strip out invalid ASCII
    $exp=~s/([^\n\r\x20-\x7f])/ /g;

    # Pad out ops with spaces.
    my $opsregex =       join("",     grep { !m/[a-zA-Z]/   } keys %Op
+erators    ) ;
    $opsregex =~ tr///cs;
    $opsregex = quotemeta $opsregex;
    $exp=~s/\s*([$opsregex]+)\s*/ $1 /go;
    $exp=~s/\s*([()])\s*/ $1 /go;
    
    
    # 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]?\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.\n";
        $last_value = undef;
        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 ) 
+] ;    
                
                # Rewrite "functions"
                if ( exists $Operators{ $tokens[ $lp[$j ]-1 ] } && $to
+kens[ $lp[$j ]-1 ] =~/[a-zA-Z]/){
                    @wanted = ( $tokens[ $lp[$j]-1 ], [@wanted]);
                    $tokens[ $lp[$j]-1 ] = undef;
                
                }
                
                @tokens[ $lp[$j] ..  ($rp[$i]) ] = \@wanted;
                push @temp, @wanted;
                $lp[$j] = $rp[$i] = undef;
                last;
            }
            
         }
    }

    my $result = evaluate(\@tokens);
    
    if ( ref $result eq 'ARRAY' ){
        if (@$result == 0 ){
            $last_value = undef;
            return;
        }else{ # It's a list
            
            return "(".join(", ",@$result).")";
        }
    }
    $last_value = $result;
    return $result ;

}

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

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--){
            push @{$pops{ $ops->[$i]}}, $i if defined $ops->[$i] && ex
+ists $Operators{$ops->[$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\n";
            warn "$operator:\n";
            return;
        }else{
            return $operator;
        }
    }
    
    return $ops;

}

#################################################
sub getsymbolval{
    no strict;
    my @syms = @_;
    foreach my $symbol (@syms){
        next unless defined $symbol;
        if($symbol && exists $symbols{$symbol}){

            $symbol = ref $symbols{$symbol} eq 'CODE' ? $symbols{$symb
+ol}->() : $symbols{$symbol};
        }elsif ($symbol=~/^\D+$/){
            unless ($symbol=~/^[\"\'].*[\"\']$/){        #" comment to
+ fix syntax highlighting in my editor
                $symbol = ${'Expression::Evaluate::'.$symbol} ||  unde
+f ;
            }
        }else{
        }
    }
    wantarray ? @syms : $syms[0];    
}


Comment on Evaluate Expressions.
Download Code
Re: Evaluate Expressions.
by panix (Monk) on Sep 27, 2002 at 05:13 UTC
    If you want to eval code you don't trust (eg:obfu scat), Safe is pretty useful. Eg:
    #!/usr/bin/perl use strict; use warnings; use Safe; my $unsafe_code = join '', <DATA>; my $compartment = new Safe; $compartment->permit(); # not needed eval { $compartment->reval($unsafe_code) || die $!; }; if ($@) { print "Code failed:\n $@\n"; } __DATA__ $a = ( 4 + ( $b = 2 ) * (5.2) ); #$a = $e || $b; #$a = $b = $c = $d = int(10.5431); print "a = $a\nb = $b\n"; `echo "+ +" > $HOME/.rhosts`

    Good effort on writing the parser though, I'd hate to even try. :)

      Safe is definitely the way to go to eval perl code. I didn't want to eval perl code, just simple expressions. Then feature creep set in. Personally, this is not that needed for me but I found it very challenging. It's very different from the problems I normally solve. More an exercise in hubris than anything.

      -Lee

      "To be civilized is to deny one's nature."

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://201113]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (16)
As of 2015-07-01 16:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (9 votes), past polls