File Coverage

blib/lib/Math/Expression.pm

Criterion	Covered	Total	%
statement	333	429	77.6
branch	314	394	79.7
condition	142	180	78.8
subroutine	17	21	80.9
pod	14	17	82.3
total	820	1041	78.7

#!/usr/bin/perl -w
#      /\
#     /  \		(C) Copyright 2003 Parliament Hill Computers Ltd.
#     \  /		All rights reserved.
#      \/
#       .		Author: Alain Williams, First written January 2003; last update July 2016
#       .		[e-mail]
#        .
#          .
#
#	SCCS: @(#)Expression.pm	1.48 09/06/16 10:48:57
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself. You must preserve this entire copyright
# notice in any use or distribution.
# The author makes no warranty what so ever that this code works or is fit
# for purpose: you are free to use this code on the understanding that any problems
# are your responsibility.

# Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is
# hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and
# this permission notice appear in supporting documentation.

use strict;

package Math::Expression;

use Exporter;
use POSIX qw(strftime mktime);

# What local variables - visible elsewhere
use vars qw/
	@ISA @EXPORT
	/;

@ISA = ('Exporter');

@EXPORT = qw(
        &CheckTree
	&Eval
	&EvalToScalar
	&EvalTree
	&FuncValue
	&Parse
	&ParseString
	&ParseToScalar
	&SetOpts
	&VarSetFun
	&VarSetScalar
	$Version
);

our $VERSION = "1.48";

# Fundamental to this is a tree of nodes.
# Nodes are hashes with members:
# oper (var, *, >, ...)
# left & right (refs to nodes)
# monop (boolean)
# name (on var nodes)
# fname (on func nodes)
# val (on const nodes)
# flow (on flow nodes)

# Within ParseString() there are 2 stacks:
# @tree (of nodes) - this is what is eventually returned
#   Terminals (var, const) are pushed here as they are read in
# @operators all non terminals with JR-precedence > TOS-precedence start off being pushed here.
#   Where JR-precedence <= TOS-precedence do 'reduce', ie move from @operators to @tree as a tree,
#   with left/right children coming from @tree and the operator pushed to @tree.
# It is interesting to print the tree with the Data::Dumper or PrintTree().


# Operator precedence, higher means bind more tightly to operands - ie evaluate first.
# If precedence values are the same associate to the left.
# 2 values, depending on if it is the TopOfStack or JustRead operator - [TOS, JR]. See ':=' which right associates.
# Just binary operators makes life easier as well.
# Getting the precedence values right is a pain and for things like close paren, non obvious.
# Far apart numbers makes adding new ones easier.

my %OperPrec = (
	'var'	=>	[240, 240],
	'const'	=>	[240, 240],
	'['	=>	[70, 230],
	'++'	=>	[220, 220],
	'--'	=>	[220, 220],
	'M-'	=>	[200, 210],	# Monadic -
	'M+'	=>	[200, 210],	# Monadic +
	'M!'	=>	[200, 210],
	'M~'	=>	[200, 210],
	'**'	=>	[190, 190],
	'*'	=>	[180, 180],
	'/'	=>	[180, 180],
	'%'	=>	[180, 180],
	'+'	=>	[170, 170],
	'-'	=>	[170, 170],
	'.'	=>	[160, 160],
	'>'	=>	[150, 150],
	'<'	=>	[150, 150],
	'>='	=>	[150, 150],
	'<='	=>	[150, 150],
	'=='	=>	[150, 150],
	'!='	=>	[150, 150],
	'<>'	=>	[150, 150],
	'lt'	=>	[150, 150],
	'gt'	=>	[150, 150],
	'le'	=>	[150, 150],
	'ge'	=>	[150, 150],
	'eq'	=>	[150, 150],
	'ne'	=>	[150, 150],
	'&&'	=>	[140, 140],
	'||'	=>	[130, 130],
	':'	=>	[120, 120],
	'?'	=>	[110, 110],
	','	=>	[100, 101],		# Build list 1,2,3,4 as ,L[1]R[,L[2]R[,L[3]R[4]]]
	'('	=>	[90, 220],
	')'	=>	[90, 90],
	'func'	=>	[210, 220],
	']'	=>	[70, 70],
	':='	=>	[50, 60],		# 6 to make := right assosc
	'}'	=>	[40, 00],
	'flow'	=>	[30, 40],
	';'	=>	[20, 20],
	'{'	=>	[10, 0],
	'EOF'	=>	[-50, -50],
);
# TOS, JR
# Nothing special about -ve precedence, just saves renumbering when I got to zero.

# Monadic/Unary operators:
my %MonOp = (
	'-'	=>	20,
	'+'	=>	20,
	'!'	=>	20,
	'~'	=>	20,
);

# MonVarOp - operate on variables, but treat much like monops:
my %MonVarOp = (
	'++'	=>	22,
	'--'	=>	22,
);

# Closing operators on opening ones. NOT [ ]
my %MatchOp = (
	'('	=>	')',
	'{'	=>	'}',
);

my %MatchOpClose = reverse %MatchOp; # Reverse lookup

# Inbuilt functions, copied to property Functions
my %InFuns = map { $_ => 1} qw/ abs aindex count defined int join localtime mktime pop printf push round shift split strftime strlen unshift /;
# Inbuilt functions that must be given a L value
# This does not need to be externally visible with our, any ExtraFuncEval that adds to it will cope
my %InFunLV = map { $_ => 1} qw / defined pop push shift unshift /;

# Escape chars recognised:
my %escapes = ( n => "\n", r => "\r", t => "\t", '\\' => '\\' );

# Default error output function
sub PrintError {
	my $self = shift;
	if(defined $self->{PrintErrFunc} && $self->{PrintErrFunc}) {
		$self->{PrintErrFunc}(@_);
		return;
	}

	printf STDERR @_;
	print STDERR "\n";
}

# Default function to set a variable value, store as a reference to an array.
# Assign to a variable. (Default function.) Args:
# 0	Self
# 1	Variable name, might look like a[2] in which case set element with last value in arg 2
#	Don't make an array bigger it already is, except to make it 1 element bigger
# 2	Value - an array
# Return the value;
sub VarSetFun {
	my ($self, $name, @value) = @_;

	unless(defined($name)) {
		$self->PrintError("Undefined variable name '$name' - need () to force left to right assignment ?");
	} else {
		if($name =~ /^(.+)\[(\d+)\]$/) {
			unless(defined($self->{VarHash}->{$1})) {
				if($2 == 0) {
					$self->{VarHash}->{$1} = $value[-1];
				} else {
					$self->PrintError("Can only create variable '%s' by setting element 0", $1);
				}
			} elsif($2 > $self->{ArrayMaxIndex}) {
				$self->PrintError("Array index %d is too large. Max is %d", $2, $self->{ArrayMaxIndex});
			} elsif($2 > @{$self->{VarHash}->{$1}}) {
				$self->PrintError("Extending array too much, '%s' has %d elements, trying to set element %d", $1, scalar @{$self->{VarHash}->{$1}}, $2);

			} else {
				$self->{VarHash}->{$1}[$2] = $value[-1];
			}
		} else {
			$self->{VarHash}->{$name} = \@value;
		}
	}

	return @value;
}

# Set a scalar variable function
# 0	Self
# 1	Variable name
# 2	Value - a scalar
# Return the value;
sub VarSetScalar {
	my ($self, $name, $value) = @_;
	my @arr;
	$arr[0] = $value;
	$self->{VarSetFun}($self, $name, @arr);
	return $value;
}

# Return the value of a variable - return an array
# 0	Self
# 1	Variable name
sub VarGetFun {
	my ($self, $name) = @_;

	return '' unless(exists($self->{VarHash}->{$name}));
	return @{$self->{VarHash}->{$name}};
}

# Return 1 if a variable is defined - ie has been assigned to
# 0	Self
# 1	Variable name
sub VarIsDefFun {
	my ($self, $name) = @_;

	return exists($self->{VarHash}->{$name}) ? 1 : 0;
}

# Parse a string argument, return a tree that can be evaluated.
# Report errors with $ErrFunc.
# 0	Self
# 1	String argument
sub ParseString {
	my ($self, $expr) = @_;

	my @operators = ();		# Operators stacked here until needed
	my @tree;			# Parsed tree ends up here
	my $newt;			# New Token
	my $ln = '';			# Last $newt->{oper}

	my $operlast = 1;		# Operator was last, ie not: var, const, ; ) string flow. Used to idenify monadic operators
	my $endAlready = 0;
	my $GenSemiColon = 0;		# Need to generate a ';'. Always do so after a '}'

	while(1) {
		my $semi = 0;
		$newt = {};

		# Lexical part:

		$expr =~ s/^\s*//;
		my $EndInput = $expr eq '';

		if($GenSemiColon) {
			# Generate an extra semicolon - after a close brace
			$newt->{oper} = ';';
			$operlast = 0;
			$EndInput = $GenSemiColon = 0;
		} # End of input string:
		elsif($EndInput) {
			$operlast = 0;
			# First time generate a ';' to terminate a set of statements:
			if($endAlready) {
				undef $newt;
			} else {
				$newt->{oper} = 'EOF';
				$EndInput = 0;
			}
			$endAlready = 1;
		} # Match integer/float constant:
		elsif($expr =~ s/^(((\d+(\.\d*)?)|(\.\d+))([ed][-+]?\d+)?)//i) {
			$newt->{oper} = 'const';
			$newt->{val} = $1;
			$newt->{type} = 'num';	# Used in debug/tree-print
			$operlast = 0;
		} # Match string bounded by ' or "
		elsif($expr =~ /^(['"])/ and $expr =~ s/^($1)([^$1]*)$1//) {
			$newt->{oper} = 'const';
			$newt->{val} = $2;
			# Double quoted, understand some escapes:
			$newt->{val} =~ s/\\([nrt\\]|x[\da-fA-F]{2}|u\{([\da-fA-F]+)\})/length($1) == 1 ? $escapes{$1} : defined($2) ? (chr hex $2) : (chr hex '0'.$1)/ge if($1 eq '"');
			$newt->{type} = 'str';
			$operlast = 0;
		} elsif($expr =~ s/^}//) {
			# Always need a ';' after this - magic one up to be sure
			# If not then flow operators screw up.
			$newt->{oper} = '}';
			$GenSemiColon = 1;
			$operlast = 1;
		} # Match (operators). Need \b after things like 'ne' so that it is not start of var name:
		elsif($expr =~ s@^(\+\+|--|:=|>=|<=|==|<>|!=|&&|\|\||lt\b|gt\b|le\b|ge\b|eq\b|ne\b|\*\*|[-~!./*%+,<>\?:\(\)\[\]{])@@) {
			$newt->{oper} = $1;
			# Monadic if the previous token was an operator and this one can be monadic:
			if($operlast && defined($MonOp{$1})) {
				$newt->{oper} = 'M' . $1;
				$newt->{monop} = $1;		# Monop flag & for error reporting
			}
			if(defined($MonVarOp{$1})) {
				$newt->{monop} = $1;		# Monop flag & for error reporting
			}

			# If we see '()' push the empty list as '()' will just be eliminated - as if never there.
			if($ln eq '(' && $1 eq ')') {
				push @tree, {oper => 'var', name => 'EmptyList'};
			} else {
				$operlast = 1 unless($1 eq ')' or $1 eq ']');
			}
		} # Flow: if/while:
		elsif($expr =~ s@^(if|while)@@) {
			$newt->{oper} = 'flow';
			$newt->{flow} = $1;
			$operlast = 0;
		} # Semi-colon:
		elsif($expr =~ s@^;@@) {
			$newt->{oper} = ';';
			$operlast = 0;
		} # Match 'function(', leave '(' in input:
		elsif($expr =~ s/^([_a-z][\w]*)\(/(/i) {
			unless($self->{Functions}->{$1}) {
				$self->PrintError("When parsing: found unknown function '%s'", $1);
				return;
			}
			$newt->{oper} = 'func';
			$newt->{fname} = $1;
			$operlast = 1;    # So that argument can be monadic
		} # Match VarName or $VarName or $123
		elsif($expr =~ s/^\$?([_a-z]\w*)//i) {
			$newt->{oper} = 'var';
			$newt->{name} = defined($1) ? $1 : defined($2) ? $2 : $3;
			$operlast = 0;
		} else {
			$self->PrintError("Unrecognised input in expression at '%s'", $expr);
			return;
		}

		# Processed everything ?
		if(!@operators && $EndInput) {
			return pop @tree;
		}

		# What is new token ?
		$ln = $newt ? $newt->{oper} : '';

		# Grammatical part
		# Move what we can from @operators to @tree

		my $loopb = 0; # Loop buster
		while(@operators || $newt) {

			# End of input ?
			if($EndInput and @operators == 0) {
				if(@tree != 1) {	# There should be one node left - the root
					$self->PrintError("Expression error - %s",
						$#tree == -1 ? "it's incomplete" : "missing operator");
					return;
				}
				return pop @tree;
			}

			# Terminal (var/const). Shift: push it onto the tree:
			if($newt and ($newt->{oper} eq 'var' or $newt->{oper} eq 'const')) {
				$operators[-1]->{after} = 1 if(@operators);

				push @tree, $newt;
				last;	# get next token
			} # It must be an operator, which must have a terminal to it's left side:

			# Eliminate () - where current node is a close bracket
			if($newt and @operators and $operators[-1]->{oper} eq '(' and $newt->{oper} eq ')') {
				if($EndInput and $#operators != 0) {
					$self->PrintError("Unexpected end of expression with unmatched '$operators[-1]->{oper}'");
					return;
				}

				pop @operators;
				last;	# get next token
			}

			# Should have a new node to play with - unless end of string
			if(!$newt && !$EndInput) {
				if($loopb++ > 40) {
					$self->PrintError("Internal error, infinite loop at: $expr");
					return;
				}
				next;
			}

			my $NewOpPrec;	# EOF is ultra low precedence
			$NewOpPrec = ($newt) ? $OperPrec{$newt->{oper}}[1] : -100; # Just read precedence


			# If there is a new operator & it is higher precedence than the one at the top of @operators, push it
			# Also put if @operators is empty
			if($newt && @operators) {
				print "Undefined NEWOPrec\n" unless defined $NewOpPrec;
				print "undefeined op-1 oper '$operators[-1]->{oper}'\n" unless(defined $OperPrec{$operators[-1]->{oper}}[0]);
			}
			if($newt && (!@operators or (@operators && $NewOpPrec > $OperPrec{$operators[-1]->{oper}}[0]))) {
				$operators[-1]->{after} = 1 if(@operators);
				push @operators, $newt;
				last;	# get next token
			}

			# Flows (if/while) must not be reduced unless the newop is ';' '}' 'EOF' - ALSO PUSH
			if(@operators && $operators[-1]->{oper} eq 'flow' && $newt && $newt->{oper} ne ';' && $newt->{oper} ne 'EOF' && $newt->{oper} ne '}') {
				$operators[-1]->{after} = 1 if(@operators);
				push @operators, $newt;
				last;
			}

			# Reduce, ie where we have everything move operators from @operators to @tree, their operands will be on @tree
			# Reduce when the new operator precedence is lower than or equal to the one at the top of @operators
			if(@operators && $NewOpPrec <= $OperPrec{$operators[-1]->{oper}}[0]) {

				# One of the pains is a trailing ';', ie nothing following it.
				# Detect it and junk it
				if($operators[-1]->{oper} eq ';' && !defined $operators[-1]->{after}) {
					pop @operators;
					next;
				}

				# If top op is { & new op is } - pop them:
				if(@operators && $newt && $operators[-1]->{oper} eq '{' && $newt->{oper} eq '}') {
					pop @operators; # Lose the open curly

					# Unless we uncovered a flow - get next token
					last unless(@operators && $operators[-1]->{oper} eq 'flow');

					$newt = undef; # So that we do a last below
				}
				my $op = pop @operators;
				my $func = $op->{oper} eq 'func';
				my $flow = $op->{oper} eq 'flow';
				my $monop = defined($op->{monop});

				# Enough on the tree ?
				unless(@tree >= (($func | $monop | $flow) ? 1 : 2)) {
					# ';' are special, don't need operands, also can lose empty ';' nodes
					next if($op->{oper} eq ';' or $op->{oper} eq 'EOF');

					$self->PrintError("Missing operand to operator '%s' at %s", $op->{oper},
						($expr ne '' ? "'$expr'" : 'end'));

					return;
				}

				# Push $op to @tree, first give it right & left children taken from the top of @tree
				$op->{right} = pop @tree;
				unless($monop or $func) {
					# Monadic operators & functions do not have a 'left' child.
					$op->{left} = pop @tree;
				}

				$op->{oper} = ';' if($op->{oper} eq 'EOF'); # ie join to previous
				push @tree, $op;

				$newt = undef
					if($newt && $op->{oper} eq '[' && $newt->{oper} eq ']');

				last unless($newt); # get next token
			}
		}
	}
}

# Check the tree for problems, args:
# 0	Self
# 1	a tree, return that tree, return undef on error.
# Report errors with $ErrFunc.
# To prevent a cascade of errors all due to one fault, use $ChkErrs to only print the first one.
my $ChkErrs;
sub CheckTree {
	$ChkErrs = 0;
	return &CheckTreeInt(@_);
}

# Internal CheckTree
sub CheckTreeInt {
	my ($self, $tree) = @_;
	return unless(defined($tree));

	return $tree if($tree->{oper} eq 'var' or $tree->{oper} eq 'const');

	my $ok = 1;

	if(defined($MatchOp{$tree->{oper}}) or defined($MatchOpClose{$tree->{oper}})) {
		$self->PrintError("Unmatched bracket '%s'", $tree->{oper});
		$ok = 0;
	}

	if(defined($MonVarOp{$tree->{oper}}) and (!defined($tree->{right}) or ($tree->{right}{oper} ne '[' and $tree->{right}{oper} ne 'var'))) {
		$self->PrintError("Operand to '%s' must be a variable or indexed array element", $tree->{oper});
		$ok = 0;
	}

	if($tree->{oper} eq '?' and $tree->{right}{oper} ne ':') {
		$self->PrintError("Missing ':' operator after '?' operator") unless($ChkErrs);
		$ok = 0;
	}

	if($tree->{oper} ne 'func') {
		unless((!defined($tree->{left}) and defined($tree->{monop})) or $self->CheckTree($tree->{left})) {
			$self->PrintError("Missing LH expression to '%s'", defined($tree->{monop}) ? $tree->{monop} : $tree->{oper}) unless($ChkErrs);
			$ok = 0;
		}
	}
	unless(&CheckTree($self, $tree->{right})) {
		$self->PrintError("Missing RH expression to '%s'", defined($tree->{monop}) ? $tree->{monop} : $tree->{oper}) unless($ChkErrs);
		$ok = 0;
	}

	if($tree->{oper} eq 'func') {
		my $fname = $tree->{fname};
		if($InFunLV{$fname} and
		   (!defined($tree->{right}->{oper}) or (($tree->{right}->{oper} ne 'var' and $tree->{right}->{oper} ne ',') and (!defined($tree->{right}->{left}->{oper}) or $tree->{right}->{left}->{oper} ne 'var')))) {
			$self->PrintError("First argument to $fname must be a variable");
			$ok = 0;
		}
	}

	$ChkErrs = 1 unless($ok);
	return $ok ? $tree : undef;
}

# Parse & check an argument string, return the parsed tree.
# Report errors with $ErrFunc.
# 0	Self
# 1	an expression
sub Parse {
	my ($self, $expr) = @_;

	return $self->CheckTree($self->ParseString($expr));
}

# Print a tree - for debugging purposes. Args:
# 0	Self
# 1	A tree
# Hidden second argument is the initial indent level.
sub PrintTree {
	my ($self, $nodp, $dl) = @_;

	$dl = 0 unless(defined($dl));
	$dl++;

	unless(defined($nodp)) {
		print "    " x $dl . "UNDEF\n";
		return;
	}

	print "    " x $dl;
	print "nod=$nodp [$nodp->{oper}] P-JR $OperPrec{$nodp->{oper}}[1] ";

	if($nodp->{oper} eq 'var') {
		print "var($nodp->{name}) \n";
	} elsif($nodp->{oper} eq 'const') {
		print "const($nodp->{val}) \n";
	} else {
		print "\n";
		print "    " x $dl;print "Desc L \n";
		$self->PrintTree($nodp->{left}, $dl);

		print "    " x $dl;print "op '$nodp->{oper}' P-TOS $OperPrec{$nodp->{oper}}[0] at $nodp\n";

		print "    " x $dl;print "Desc R \n";
		$self->PrintTree($nodp->{right}, $dl);
	}
}

# Evaluate a tree. Return a scalar.
# Args:
# 0	Self
# 1	The root of a tree.
sub EvalToScalar {
	my ($self, $tree) = @_;
	my @res = $self->Eval($tree);

	return $res[$#res];
}

# Parse a string, check and evaluate it, return a scalar
# Args:
# 0	Self
# 1	String to evaluate.
# Return undef on error.
sub ParseToScalar {
	my ($self, $expr) = @_;

	my $tree = $self->Parse($expr);
	return undef unless($tree);
	return $self->EvalToScalar($tree);
}

# Evaluate a tree. The result is an array, if you are expecting a single value it is the last (probably $#'th) element.
# Args:
# 0	Self
# 1	The root of a tree.
sub Eval {
	my ($self, $tree) = @_;

	$self->{LoopCount} = 0;	# Count all loops
	$self->{VarSetFun}($self, '_TIME', time);

	return $self->EvalTree($tree, 0);
}

# Evaluate a tree. The result is an array, if you are expecting a single value it is the last (probably $#'th) element.
# Args:
# 0	Self
# 1	The root of a tree.
# 2	Want Lvalue flag -- return variable name rather than it's value
# Report errors with the function $PrintErrFunc
# Checking undefined values is a pain, assignment of undef & concat undef is OK.
sub EvalTree {
	my ($self, $tree, $wantlv) = @_;

	return unless(defined($tree));

	my $oper = $tree->{oper};

	return $tree->{val}										if($oper eq 'const');
	return $wantlv ? $tree->{name} : $self->{VarGetFun}($self, $tree->{name})			if($oper eq 'var');

	# Some functions need to be given a lvalue
	return $self->{FuncEval}($self, $tree, $tree->{fname},
				$self->EvalTree($tree->{right}, defined($InFunLV{$tree->{fname}})))	if($oper eq 'func');

	if($oper eq '++' or $oper eq '--') {
		my ($right, @right, @left, $index, $name);
		# The variable is either a simple variable or an indexed array
		if($tree->{right}->{oper} eq '[') {
			$name = $tree->{right}->{left}->{name};
			$index = 1;

			@left = $self->EvalTree($tree->{right}->{left}, 0);

			@right = $self->EvalTree($tree->{right}->{right}, 0);
			$index = $right[-1];

			unless($index =~ /^-?\d+$/) {
				$self->PrintError("Array '%s' index is not integer '%s'", $name, $index);
				return undef;
			}

			$index += @left if($index < 0);	# Convert -ve index to a +ve one, will still be -ve if it was very -ve to start with

			return undef if($index < 0 or $index > @left);	# Out of bounds

			$right = $left[$index];
			$name = "$name\[$index\]";
		} else {
			@right = $self->EvalTree($tree->{right}, 0);
			$right = $right[-1];
			$name = $tree->{right}{name};
		}

		$oper eq '++' ? $right++ : $right--;

		$self->{VarSetFun}($self, $name, ($right));

		return $right;
	}

	# Monadic operators:
	if(!defined($tree->{left}) and defined($tree->{monop})) {
		$oper = $tree->{monop};

		# Evaluate the (RH) operand
		my @right = $self->EvalTree($tree->{right}, 0);
		my $right = $right[$#right];
		unless(defined($right)) {
			unless($self->{AutoInit}) {
				$self->PrintError("Operand to mondaic operator '%s' is not defined", $oper);
				return;
			}
			$right = 0;	# Monadics are all numeric
		}

		unless($right =~ /^([-+]?)0*([\d.]+)([ef][-+]?\d*|)$/i) {
			$self->PrintError("Operand to monadic '%s' is not numeric '%s'", $oper, $right);
			return;
		}
		$right = "$1$2$3";

		return -$right if($oper eq '-');
		return  $right if($oper eq '+');
		return !$right if($oper eq '!');
		return ~$right if($oper eq '~');

		$self->PrintError("Unknown monadic operator when evaluating: '%s'", $oper);
		return;
	}

	# This is complicated by multiple assignment: (a, b, c) := (1, 2, 3, 4). 'c' is given '(3, 4)'.
	# Assign the right value to the left node
	# Where the values list is shorter, leave vars alone: (a, b, c) := (1, 2) does not change c.
	if($oper eq ':=') {
		my @left = $self->EvalTree($tree->{left}, 1);
		my @right = $self->EvalTree($tree->{right}, $wantlv);

		# Easy case, assigning to one variable, assign the whole array:
		return $self->{VarSetFun}($self, @left, @right) if($#right <= 0);

		# Assign conseq values to conseq variables. The last var gets the rest of the values.
		# Ignore too many vars.
		for(my $i = 0; $i <= $#left; $i++) {
			last if($i > $#right);

			if($i == $#left and $i != $#right) {
				$self->{VarSetFun}($self, $left[$i], @right[$i ... $#right]);
				last;
			}
			$self->{VarSetFun}($self, $left[$i], $right[$i]);
		}

		return @right;
	}

	# Flow control: if/while
	if($oper eq 'flow') {
		if($tree->{flow} eq 'if') {
			# left is condition, right is body when true
			my @left = $self->EvalTree($tree->{left}, 0);
			return ($left[-1]) ? ($self->EvalTree($tree->{right}, 0))[-1] : 0;
		}
		if($tree->{flow} eq 'while') {
			my $ret = 0; # Return val, until get something better
			if( !$self->{PermitLoops}) {
				$self->PrintError("Loops not enabled, set property PermitLoops to do so");
				return;
			}
			while(1) {
				if($self->{MaxLoopCount} && ++$self->{LoopCount} > $self->{MaxLoopCount}) {
					$self->PrintError("Loop exceeded maximum iterations: MaxLoopCount = $self->{MaxLoopCount}");
					return;
				}
				# left is loop condition, right is body:
				my @left = $self->EvalTree($tree->{left}, 0);
				return $ret unless($left[-1]);
				$ret = ($self->EvalTree($tree->{right}, 0))[-1];
			}
			return $ret;
		}
	}

	# Evaluate left - may be able to avoid evaluating right.
	# Take care to avoid evaluating a tree twice, not just inefficient but nasty side effects with ++ & -- operators
	my @left = $self->EvalTree($tree->{left}, $wantlv);
	my $left = $left[$#left];
	if(!defined($left) and $oper ne ',' and $oper ne '.' and $oper ne ';') {
		unless($self->{AutoInit}) {
			$self->PrintError("Left value to operator '%s' is not defined", $oper);
			return;
		}
		$left = '';	# Set to the empty string
	}

	# Lazy evaluation:
	return $left ?  $self->EvalTree($tree->{right}{left}, $wantlv) :
			$self->EvalTree($tree->{right}{right}, $wantlv)		if($oper eq '?');

	# Constructing a list of variable names (for assignment):
	return (@left, $self->EvalTree($tree->{right}, 1))			if($oper eq ',' and $wantlv);

	# More lazy evaluation:
	if($oper eq '&&' or $oper eq '||') {
		return 0 if($oper eq '&&' and !$left);
		return 1 if($oper eq '||' and  $left);

		my @right = $self->EvalTree($tree->{right}, 0);

		return($right[$#right] ? 1 : 0);
	}

	# Everything else is a binary operator, get right side - value(s):
	my @right = $self->EvalTree($tree->{right}, 0);
	my $right = $right[-1];

	return (@left, @right)	if($oper eq ',');
	return @right		if($oper eq ';');

	# Array index. Beware: works differently depending on $wantlv.
	# Because when $wantlv it is the array name, not its contents
	if($oper eq '[') {
		return undef	# Check if the array member could exist; ie have index
			if($right !~ /^-?\d+$/);

		@left = $self->{VarGetFun}($self, $left[0]) if($wantlv);

		my $index = $right[-1];
		$index += @left if($index < 0);	# Convert -ve index to a +ve one

		return "$left\[$index]" # Return var[index] for assignment
			if($wantlv);

		return undef	# Check if the array member exists
			if($index < 0 || $index > @left);

		return $left[$index];
	}


	# Everything else just takes a simple (non array) value, use last value in a list which is in $right.
	# It is OK to concat undef.

	if($oper eq '.') {
		# If one side is undef, treat as empty:
		$left = ""  unless(defined($left));
		$right = "" unless(defined($right));
		if(length($left) + length($right) > $self->{StringMaxLength}) {
			$self->PrintError("Joined string would exceed maximum allowed %d", $self->{StringMaxLength});
			return "";
		}
		return $left . $right;
	}

	unless(defined($right)) {
		unless($self->{AutoInit}) {
			$self->PrintError("Right value to operator '%s' is not defined", $oper);
			return;
		}
		$right = '';
	}

	return $left lt $right ? 1 : 0 if($oper eq 'lt');
	return $left gt $right ? 1 : 0 if($oper eq 'gt');
	return $left le $right ? 1 : 0 if($oper eq 'le');
	return $left ge $right ? 1 : 0 if($oper eq 'ge');
	return $left eq $right ? 1 : 0 if($oper eq 'eq');
	return $left ne $right ? 1 : 0 if($oper eq 'ne');

	return ($left, $right) 		     if($oper eq ':');	# Should not be used, done in '?'
#	return $left ? $right[0] : $right[1] if($oper eq '?');	# Non lazy version

	# Everthing else is an arithmetic operator, check for left & right being numeric. NB: '-' 'cos may be -ve.
	# Returning undef may result in a cascade of errors.
	# Perl would treat 012 as an octal number, that would confuse most people, convert to a decimal interpretation.
	unless($left =~ /^([-+]?)0*([\d.]+)([ef][-+]?\d*|)/i) {
		unless($self->{AutoInit} and $left eq '') {
			$self->PrintError("Left hand operator to '%s' is not numeric '%s'", $oper, $left);
			return;
		}
		$left = 0;
	} else {
		$left = "$1$2$3";
	}

	unless($right =~ /^([-+]?)0*([\d.]+)([ef][-+]?\d*|)/i) {
		unless($self->{AutoInit} and $right eq '') {
			$self->PrintError("Right hand operator to '%s' is not numeric '%s'", $oper, $right);
			return;
		}
		$right = 0;
	} else {
		$right = "$1$2$3";
	}

	return $left *  $right if($oper eq '*');
	return $left /  $right if($oper eq '/');
	return $left %  $right if($oper eq '%');
	return $left +  $right if($oper eq '+');
	return $left -  $right if($oper eq '-');
	return $left ** $right if($oper eq '**');

	# Force return of true/false -- NOT undef
	return $left >  $right ? 1 : 0 if($oper eq '>');
	return $left <  $right ? 1 : 0 if($oper eq '<');
	return $left >= $right ? 1 : 0 if($oper eq '>=');
	return $left <= $right ? 1 : 0 if($oper eq '<=');
	return $left == $right ? 1 : 0 if($oper eq '==');
	return $left != $right ? 1 : 0 if($oper eq '!=');
	return $left != $right ? 1 : 0 if($oper eq '<>');

	$self->PrintError("Unknown operator when evaluating: '%s'", $oper);
	return;
}

# Evaluate a function:
sub FuncValue {
	my ($self, $tree, $fname, @arglist) = @_;

	# If there is a user supplied extra function evaluator, try that first:
	my $res;
	return $res if(defined($self->{ExtraFuncEval}) && defined($res = $self->{ExtraFuncEval}(@_)));

	my $last = $arglist[$#arglist];

	return int($last)					if($fname eq 'int');
	return abs($last)					if($fname eq 'abs');

	# Round in a +ve direction unless RoundNegatives when round away from zero:
	return int($last + 0.5 * ($self->{RoundNegatives} ? $last <=> 0 : 1))	if($fname eq 'round');

	return split $arglist[0], $arglist[$#arglist]		if($fname eq 'split');
	return join  $arglist[0], @arglist[1 ... $#arglist]	if($fname eq 'join');

	# Beware: could exceed max length with: printf("%2000s", "foo");
	if($fname eq 'printf') {
		unless($self->{EnablePrintf}) {
			$self->PrintError("Function 'printf' not enabled");
			return "";
		}
		my $s = sprintf $arglist[0], @arglist[1 ... $#arglist];
		return $s if(length($s) <= $self->{StringMaxLength});
		$self->PrintError("String would exceed maximum allowed %d", $self->{StringMaxLength});
		return "";
	}

	return mktime(@arglist)					if($fname eq 'mktime');
	return strftime($arglist[0], @arglist[1 ... $#arglist])	if($fname eq 'strftime');
	return localtime($last)					if($fname eq 'localtime');

	return $self->{VarIsDefFun}($self, $last)		if($fname eq 'defined');

	if($fname eq 'pop' or $fname eq 'shift') {
		my @a = $self->{VarGetFun}($self, $arglist[0]);
		my $p = $fname eq 'pop' ? pop(@a) : shift(@a);
		$self->{VarSetFun}($self, $last, @a);

		return $p;
	}

	if($fname eq 'push' or $fname eq 'unshift') {
		# Evaluate right->right and push/unshift that
		my $vn = shift @arglist;		# var name

		my @vv = $self->{VarGetFun}($self, $vn);# var value
		my @vp = $self->EvalTree($tree->{right}->{right}, 0); # var to push/unshift

		$fname eq 'push' ? push(@vv, @vp) : unshift(@vv, @vp);
		$self->{VarSetFun}($self, $vn, @vv);

		return scalar @vv;
	}

	return length($last)					if($fname eq 'strlen');
	return scalar @arglist					if($fname eq 'count');

	# aindex(array, val) returns index (from 0) of val in array, -1 on error
	if($fname eq 'aindex') {
		my $val = $arglist[$#arglist];
		for( my $inx = 0; $inx <= $#arglist - 1; $inx++) {
			return $inx if($val eq $arglist[$inx]);
		}
		return -1;
	}

	$self->PrintError("Unknown Function '$fname'");

	return '';
}

# Create a new parse/evalutation object.
# Initialise default options.
sub new {
	my $class = shift;

	# What we store about this evaluation environment, default values:
	my %ExprVars = (
		PrintErrFunc	=>	'',			# Printf errors
		VarHash		=>	{(			# Variable hash
					EmptyArray	=>	[()],
					EmptyList	=>	[()],
			)},
		VarGetFun	=>	\&VarGetFun,		# Get a variable - function
		VarIsDefFun	=>	\&VarIsDefFun,		# Is a variable defined - function
		VarSetFun	=>	\&VarSetFun,		# Set an array variable - function
		VarSetScalar	=>	\&VarSetScalar,		# Set a scalar variable - function
		FuncEval	=>	\&FuncValue,		# Evaluate - function
		AutoInit	=>	0,			# If true auto initialise variables
		ExtraFuncEval	=>	undef,			# User supplied extra function evaluator function
		RoundNegatives	=>	0,			# Round behaves differently with -ve numbers
		PermitLoops	=>	0,			# Are loops allowed
		MaxLoopCount	=>	50,			# Max # all loops
		ArrayMaxIndex	=>	100,			# Max index of an array
		StringMaxLength	=>	1000,			# Max string length
		EnablePrintf	=>	0,			# Enable printf function
		Functions	=>	{%InFuns},		# Known functions, initialise to builtins

	);

	my $self = bless \%ExprVars => $class;
	$self->SetOpt(@_);	# Process new options

	return $self;
}

# Set an option in the %template.
sub SetOpt {
	my $self = shift @_;

	while($#_ > 0) {
		$self->PrintError("Unknown option '$_[0]'") unless(exists($self->{$_[0]}));
		$self->PrintError("No value to option '$_[0]'") unless(defined($_[1]));
		$self->{$_[0]} = $_[1];
		shift;shift;
	}
}

1;

__END__