http://www.perlmonks.org?node_id=201113

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]; }

Replies are listed 'Best First'.
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."