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