view release on metacpan or  search on metacpan

Expression.pm  view on Meta::CPAN

			# 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) = @_;

Expression.pm  view on Meta::CPAN

	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');