File Coverage

blib/lib/JE/Code.pm

Criterion	Covered	Total	%
statement	576	639	90.1
branch	351	414	84.7
condition	170	211	80.5
subroutine	81	92	88.0
pod	4	7	57.1
total	1182	1363	86.7

package JE::Code;

our $VERSION = '0.066';

use strict;
use warnings; no warnings 'utf8', 'recursion';

#use Data::Dumper;
use Carp 1.01 'shortmess';
use Exporter 5.57 'import';
use Scalar::Util 'tainted';

our @CARP_NOT = 'JE';
our @EXPORT_OK = 'add_line_number';

use constant T => ${^TAINT}; # perl doesn’t optimise if(${AINT}) away

require JE::Object::Error;
require JE::Object::Error::ReferenceError;
require JE::Object::Error::SyntaxError;
require JE::Object::Error::TypeError;
require JE::Object::Function;
require JE::Object::Array;
require JE::Boolean;
require JE::Object;
require JE::Parser;
require JE::Number;
require JE::LValue;
require JE::String;
require JE::Scope;

sub add_line_number; # so I can call it without parentheses in sub execute


# This is documented in a POD comment at the bottom of the file.
sub parse {
	my($global, $src, $file, $line) = @_;

	($src, my ($tree, $vars)) = JE::Parser::_parse(
		program => $src, $global, $file, $line
	);

	$@ and return;

#print Dumper $tree;

	my $r= bless { global     => $global,
	               ( $JE::Parser::_parser
	                 ? (parser => $JE::Parser::_parser)
	                 : () ),
	               source     => \$src,
	               file       => $file,
	               line       => $line,
	               vars       => $vars,
	               tree       => $tree };
	# $self->{source} is a reference, so that we can share the same
	# source between code objects without the extra memory overhead
	# that copying it  would  have.  (Some  JS  script  files  are
	# rather large.)

	$r->optimise
	 if   $ENV{'YES_I_WANT_JE_TO_OPTIMISE'}
	  and $ENV{'YES_I_WANT_JE_TO_OPTIMISE'} ne 2;

	$r;
}




sub execute_till { # ~~~ Should this be made public?
	(my $code, local our $counting) = (shift,shift);
	local our $ops = 0;
	JE_Code_OP: {
		return $code->execute(@_);
	}
	# If we get here, then we reached the max number of ops.
	$@ = shortmess "max_ops ($counting) exceeded";
	return undef;
}

sub set_global {
	my $code = shift;
	my $old = $code->{global};
	$code->{global} = $_[0];
	{for(@{$code->{cache}||last}) {
		ref eq 'JE::Code' and $_->set_global($_[0]);
	}}
	{for(@{$code->{vars}||last}){
		ref && ref $$_[4] eq 'JE::Code'
		    && $$_[4]->set_global($_[0])
	}}
	defined $old or return;
	my @stack = $code->{tree};
	local *@;
	while(@stack) {
	  for(shift @stack) {
	    for(@$_[1..$#$_]) {
	      my $r = ref || next;
	      $r =~ /^(?:ARRAY\z|JE::Code::)/
	        and push @stack, $_, =~ next;
	      $r eq 'JE::Boolean'
	        and $_ = qw(f t)[$_->value], next;
	      $r eq 'JE::Number'
	        and $_ = $_->value, next;
	      $r eq 'JE::String'
	        and $_ = "s".$_->value16, next;
	      $r eq 'JE::Null' and $_ = 'n', next;
	      $r eq 'JE::Object::RegExp'
	          and $_ = [$_->{source}->value, $$$_{regexp_flags}],
	              next;
	    }
	  }
	}
	return;
}

sub optimise {
	require 'JE/toperl.pl';
	goto &{'optimise'};
}

# Variables pertaining to the current execution context
our $code; # JE::Code object, not source code
our $this;
our $scope;
our $parser;
our $pos; # position within the source code; used to calculate a line no.
our $taint;
our $ops;
our $counting;
our $global;
our $return;
our $cache;

sub execute {
	local $code = shift;
	local $global = $$code{global};

	# We check $ops’ definedness to avoid resetting the op count when
	# called recursively.
	if(!defined our $ops and my $max_ops = $global->max_ops) {
		unshift @_, $code, $max_ops;
		goto &execute_till;
	}

	local $this = defined $_[0] ? $_[0] : $global;
	shift;

	local $scope = shift || bless [$global], 'JE::Scope';

	my $code_type = shift || 0;

	local our $taint = substr(${$$code{source}},0,0) if T;

	my $rv;
	eval {
		# passing these values around is too
		# cumbersome
		local $JE::Code::parser = $code->{parser}; # might be
		local our $pos;                            # undef
		local our $code = $code;
		local $JE::Code::Expression::_eval   = $code_type == 1;

		package JE::Code::Statement;
		local our $_label;
		package JE::Code;
		# This $return variable has two uses. It holds the return
		# value when the JS 'return' statement calls 'last RETURN'.
		# It also is used by statements that return values. It is
		# necessary to use this var, rather than simply returning
		# the value (as in v0.016 and earlier), in order to make
		# 'while(true) { 3; break }'  return  3,  rather  than
		#  undefined.
		local $return;
		local $cache = $$code{cache}||=[];

		RETURN: {
		BREAK: {
		CONT: {
			JE'Code'Statement'_create_vars();
			$$code{sub} ? &{$$code{sub}} :
			$$code{psrc}? (
			# ~~~ temporary hack:
				($$code{psrc}) = $$code{psrc} =~/(.*)/s,
				&{$$code{sub} =
				eval{ eval("sub{$$code{psrc}}")||die }
				|| die "Internal error that should never"
				   . " happen (please report this): $@: "
				   . $$code{psrc}
			}):
			$$code{tree}->eval;
			$code_type == 2 # function
				or defined $return && ($rv = $return);
			goto FINISH;
		}

		if($JE::Code::Statement::_label) {
			 die new JE::Object::Error::SyntaxError $global,
		  	 add_line_number
			"continue $JE::Code::Statement::_label: label " .
		  	"'$JE::Code::Statement::_label' not found";
		} else { goto FINISH; }

		} # end of BREAK

		if($JE::Code::Statement::_label) {
			 die new JE::Object::Error::SyntaxError $global,
			 add_line_number
		  	"break $JE::Code::Statement::_label: label " .
		  	"'$JE::Code::Statement::_label' not found";
		} else { goto FINISH; }

		} # end of RETURN

		$rv = $return;


		FINISH:  # I have to  put  this  here  inside  the  eval,
		         # because 'eval { goto label }; label:' causes a
		         # a bus error in p5.8.8 if a tie handler  is  in
		         # the call stack (fixed in 5.9.5).
	};

	T and defined $rv and tainted $taint and $rv->can('taint')
		and $rv = taint $rv $taint;

	if(ref $@ eq '' and $@ eq '') {
		!defined $rv and $rv = $scope->undefined;
	}
	else {
		# Catch-all for any errors not dealt with elsewhere
		$@ = _objectify_error($@);
	}

	$rv;
}

sub add_line_number {
	my $msg = shift;
	my $code = @_ ? shift : $code;
	my $pos  = @_ ? shift : $pos ;
	$msg =~  /\n\z/ and return $msg;
	defined(my $file = ($code || return $msg)->{file})
		or defined $pos or return $msg;
	my $first_line = $code->{line};
	defined $first_line or $first_line = 1;
	if(defined $pos) {
	    no warnings 'uninitialized';
	    "$msg at $file" . ', ' x defined($file) . 'line ' .
	        ($first_line + (() = substr(${$code->{source}},0,$pos) =~
	            /\cm\cj?|[\cj\x{2028}\x{2029}]/g))
	        . ".\n";
	} else {
	    "$msg in $file.\n"
	}
}

sub _objectify_error {
	my $msg = shift;

	ref $msg and return $global->upgrade($msg);

	my $class = 'JE::Object::Error';

	if($msg =~ /^Can't\ locate\ object\ method\
	    "(?:c(?:all|onstruct)|apply|invoke_with)"/x) {
	     # ~~~ the ‘apply’ in there is legacy and can be removed b4 v1
		$class = 'JE::Object::Error::TypeError';
		$msg = "Argument to new is not a constructor";
	}

	new $class $global, add_line_number $msg;
}

sub DDS_freeze {
	my $self = shift;
	my $copy = bless {%$self}, ref $self;
	delete $copy->{sub};
	$copy;
}



package JE::Code::Statement; # This does not cover expression statements.

our $VERSION = '0.066';

use subs qw'_eval_term';
use List::Util 'first';

our( $_label);

*_eval_term = *JE::Code::Expression::_eval_term;
import JE::Code 'add_line_number';
sub add_line_number;


# Note: each statement object is an array ref. The elems are:
# [0] - an array ref containing
#       [0] - the starting position in the source code and
#       [1] - the ending position
# [1] - the type of statement
# [2..$#] - the various expressions/statements that make up the statement

sub eval {  # evaluate statement
	my $stm = shift;

	my $type = $$stm[1];
	$type eq 'empty' || $type eq 'function' and return;

	my @labels;
	$pos = $$stm[0][0];

	if ($type eq 'labelled') {
		@labels = @$stm[2..$#$stm-1];
		if ($$stm[-1][1] =~ /^(?:do|while|for|switch)\z/) {
			$stm = $$stm[-1];
			$type = $$stm[1];
			no warnings 'deprecated';
			goto LOOPS; # skip unnecessary if statements
		}

		BREAK: {
			my $returned = $$stm[-1]->eval;
			defined $returned and $return = $returned
		}

		# Note that this has 'defined' in it, whereas the similar
		# 'if' statement further down where the loop constructs are
		# doesn't. This is because 'break' without a label sets
		# $_label to '' and exits loops and switches.
		if(! defined $_label || first {$_ eq $_label} @labels) {
			undef $_label;
			return;
		} else {
			no warnings 'exiting';
			last BREAK;
		}
	}

	if ($type eq 'statements') {

		# Execute the statements, one by one, and return the return
		# value of the last statement that actually returned one.
		my $returned;
		for (@$stm[2..$#$stm]) {
			next if $_ eq 'empty';
			defined($returned = $_->eval) and
				$return = $returned,
				ref $return eq 'JE::LValue'
					&& get $return;
		}
		return;
	}
	if ($type eq 'var') {
		for (@$stm[2..$#$stm]) { if (@$_ == 2) {
			my $ret = _eval_term $$_[1];
			ref $ret eq'JE::LValue' and $ret = get $ret;
			$scope->find_var($$_[0])->set($ret);
		}}
		return;
	}
	if ($type eq 'if') {
		#            2       3          4
		# we have:  expr statement statement?
		my $returned;
		if ($$stm[2]->eval->to_boolean->value) {
			$$stm[3] eq 'empty' or $returned = $$stm[3]->eval;
		}
		else {
			exists $$stm[4]
				&& $$stm[4] ne 'empty'
				and $returned = $$stm[4]->eval;
		}
		defined $returned and $return = $returned;
		return
	}
	if ($type =~ /^(?:do|while|for|switch)\z/) {
		# We have one of the following:
		#
		#  1      2          3          4          5
		# 'do'    statement  expression
		# 'while' expression statement
		# 'for'   expression 'in'       expression statement
		# 'for'   var_decl   'in'       expression statement
		# 'for'   expression expression expression statement
		# 'for'   var_decl   expression expression statement
 		#
		# In those last two cases, expression may be 'empty'.
		# (See further down for 'switch').

		no warnings 'exiting';

		LOOPS:
		my $returned;

		BREAK: {
		if ($type eq 'do') {
			do {
			  CONT: {
			    defined ($returned = ref $$stm[2]
			      ? $$stm[2]->eval : undef)
			    and $return = $returned;
			  }

			  if($_label and
			     !first {$_ eq $_label} @labels) {
			       goto NEXT;
			  }
			  undef $_label;
			} while $$stm[3]->eval->to_boolean->value;
		}
		elsif ($type eq 'while') {
			CONT: while ($$stm[2]->eval->to_boolean->value) {
				defined ($returned = ref $$stm[3]
					? $$stm[3]->eval : undef)
				and $return = $returned;
			}
			continue {
				if($_label and
				   !first {$_ eq $_label} @labels) {
					goto NEXT;
				}
			}
			undef $_label;
		}
		elsif ($type eq 'for' and $$stm[3] eq 'in') {
			my $left_side = $$stm[2];
			if ($left_side->[1] eq 'var') {
				$left_side->eval;
				$left_side = $left_side->[2][0];
				# now contains the identifier
			}
			my $obj = $$stm[4]->eval;
			$obj = $obj->get if ref $obj eq 'JE::LValue';
			ref($obj) =~ /^JE::(?:Undefined|Null)\z/
			 # ~~~ Do we need undef $_label here?
			 and undef $_label, return;
			my @keys = $obj->keys;
			CONT: for(@keys) {
				if($_label and
				   !first {$_ eq $_label} @labels) {
					goto NEXT;
				}
				undef $_label;

				next if not defined $obj->prop($_);
				# in which case it's been deleted

				(ref $left_side ? $left_side->eval :
					$scope->find_var($left_side))
				  ->set(_new JE::String $global, $_);

				defined ($returned = ref $$stm[5]
					? $$stm[5]->eval : undef)
				and $return = $returned;
			}

			# In case 'continue LABEL' is called during the
			# last iteration of the loop
			if($_label and
			   !first {$_ eq $_label} @labels) {
				next CONT;
			}
			undef $_label;

		}
		elsif ($type eq 'for') { # for(;;)
			my $tmp;
			CONT: for (
				$tmp = ref $$stm[2] && $$stm[2]->eval,
				ref $tmp eq 'JE::LValue' && get $tmp;

				ref $$stm[3]
					? $$stm[3]->eval->to_boolean->value
					: 1;

				do{if($_label and
				     !first {$_ eq $_label} @labels) {
				       goto NEXT;
				  }
				  undef $_label;
				},
				$tmp = ref $$stm[4] && $$stm[4]->eval,
				ref $tmp eq 'JE::LValue' && get $tmp
			) {
				defined ($returned = ref $$stm[5]
					? $$stm[5]->eval : undef)
				and $return = $returned;
			}
		}
		else { # switch
			# $stm->[2] is the parenthesized
			# expression.
			# Each pair of elements thereafter
			# represents one case clause, an expr
			# followed by statements, except for
			# the default clause, which has the
			# string 'default' for its first elem


			# Evaluate the expression in the header
			my $given = $$stm[2]->eval;
			$given = get $given if ref $given eq 'JE::LValue';

			# Look through the case clauses to see
			# which it matches. At the same time,
			# look for the default clause.

			no strict 'refs';

			my($n, $default) = 1;
			while (($n+=2) < @$stm) {
				if($$stm[$n] eq 'default') {
					$default = $n; next;
				}

				# Execute the statements if we have a match
				if("JE::Code::Expression::in==="->(
					$given, $$stm[$n]->eval
				  )) {
					$n++;
					do {
						$$stm[$n]->eval;
					} while ($n+=2) < @$stm;
					undef $default;
					last;
				}
			} ;

			# If we can't find a case that matches, but we
			# did find a default (and $default was not erased
			# when a case matched)
			if(defined $default) {
				$n = $default +1;
				do { $$stm[$n]->eval }
					while ($n+=2) < @$stm;
			}
		} # switch

		} # end of BREAK


		if(!$_label || first {$_ eq $_label} @labels) {
			undef $_label;
			return;
		} else {
			last BREAK;
		}

		NEXT: next CONT;
	}
	if ($type eq 'continue') {
		no warnings 'exiting';
		$_label = exists $$stm[2] ? $$stm[2] : '';
		next CONT;
	}
	if ($type eq 'break') {
		no warnings 'exiting';
		$_label = exists $$stm[2] ? $$stm[2] : '';
		last BREAK;
	}
	if ($type eq 'return') {
		no warnings 'exiting';
		if (exists $$stm[2]) {
			ref ($return = $$stm[2]->eval) eq 'JE::LValue'
			and $return = get $return;
		} else { $return = undef }
		last RETURN;
	}
	if ($type eq 'with') {
		local $scope = bless [
			@$scope, $$stm[2]->eval->to_object
		], 'JE::Scope';
		my $returned = $$stm[3]->eval;
		defined $returned and $return = $returned;
		return;
	}
	if ($type eq 'throw') {
		my $excep;
		if (exists $$stm[2]) {
			ref ($excep = $$stm[2]->eval) eq 'JE::LValue'
			and $excep = get $excep;
		}
		die defined $excep? $excep : $global->undefined;
	}
	if ($type eq 'try') {
		# We have one of the following:
		#   1     2     3     4     5
		# 'try' block ident block       (catch)
		# 'try' block block             (finally)
		# 'try' block ident block block (catch & finally)

		my $result;
		my $propagate;

		eval { # try
			local $return;
			no warnings 'exiting';
			RETURN: {
			BREAK: {
			CONT: {
				$result = $$stm[2]->eval;
				goto SAVERESULT;
			} $propagate = sub{ next CONT }; goto SAVERESULT;
			} $propagate = sub{ last BREAK }; goto SAVERESULT;
			} $propagate = sub{ last RETURN }; goto SAVERESULT;

			SAVERESULT:
			defined $result or $result = $return;
			goto FINALLY;
		};
		# check ref first to avoid the overhead of overloading
		if (ref $@ || $@ ne '' and !ref $$stm[3]) { # catch
			undef $result; # prevent { 3; throw ... } from
			                # returning 3

			# Turn miscellaneous errors into Error objects
			$@ = JE'Code'_objectify_error($@);

			(my $new_obj = new JE::Object $global)
			 ->prop({
				name => $$stm[3],
				value => $@,
				dontdel => 1,
			});
			local $scope = bless [
				@$scope, $new_obj
			], 'JE::Scope';

			eval { # in case the catch block ends abruptly
			  local $return;
			  no warnings 'exiting';
			  RETURN: {
			  BREAK: {
			  CONT: {
			    $result = $$stm[4]->eval;
			    goto SAVE;
			  } $propagate = sub{ next CONT }; goto SAVE;
			  } $propagate = sub{ last BREAK }; goto SAVE;
			  } $propagate = sub{ last RETURN }; goto SAVE;

			  SAVE:
			  defined $result or $result = $return;
			  $@ = '';
			}
		}
		# In case the 'finally' block resets $@:
		my $exception = $@;
		FINALLY:
		if ($#$stm == 3 or $#$stm == 5) {
			$$stm[-1]->eval;
		}
		defined $exception and ref $exception || $exception ne ''
			and die $exception;
		$return = $result if defined $result;
		$propagate and &$propagate();
	}
}

sub _create_vars {  # Process var and function declarations
	my $vars = $code->{vars};
	for(@$vars) {
		if(ref) { # function
			# format: [[...], function=> 'name',
			#          [ (params) ], $statements_obj, \@vars ]
			# With optimisation on, the $statements_obj will
			# actually be a code object.
			$scope->[-1]->delete($$_[2], 1);
			my $new_code_obj;
			if(ref $$_[4] eq 'JE::Code') {
				$new_code_obj = $$_[4]
			}
			else {
			  ($new_code_obj = bless {
			    map+($_=>$code->{$_}),
			      qw/global source file line/
			  }, 'JE::Code')
			  ->{tree} = $$_[4];
			  $new_code_obj->{vars} = $$_[5];
			}
			$scope->new_var($$_[2], new JE::Object::Function {
				scope    => $scope,
				name     => $$_[2],
				argnames => $$_[3],
				function => $new_code_obj
			});
		}
		else {
			$scope->new_var($_);
		}
	}
}




package JE::Code::Expression;

our $VERSION = '0.066';

# B::Deparse showed me how to get these values.
use constant nan => sin 9**9**9;
use constant inf => 9**9**9;

use subs qw'_eval_term';
use POSIX 'fmod';
use Scalar::Util 'tainted';

import JE::Code 'add_line_number';
sub add_line_number;

BEGIN{*T = *JE::Code::T;}


#----------for reference------------#
#sub _to_int {
	# call to_number first
	# then...
	# NaN becomes 0
	# 0 and Infinity remain as they are
	# other nums are rounded towards zero ($_ <=> 0) * floor(abs)
#}

# Note that abs in ECMA-262
#sub _to_uint32 {
	# call to_number, then ...

	# return 0 for Nan, -?inf and 0
	# (round toward zero) % 2 ** 32
#}

#sub _to_int32 {
	# calculate _to_uint32 but subtract 2**32 if the result >= 2**31
#}

#sub _to_uint16 {
	# just like _to_uint32, except that 2**16 is used instead.
#}


#---------------------------------#

{ # JavaScript operators
  # Note: some operators are not dealt with here, but inside
  #       sub eval.
	no strict 'refs';
	*{'predelete'} = sub {
		ref(my $term = shift) eq 'JE::LValue' or return
			new JE::Boolean $global, 1;
		my $base = $term->base;
		new JE::Boolean $global,
			defined $base ? $base->delete($term->property) : 1;
	};
	*{'prevoid'} = sub {
		my $term = shift;
		$term = get $term while ref $term eq 'JE::LValue';
		return $global->undefined;
	};
	*{'pretypeof'} = sub {
		my $term = shift;
		ref  $term eq 'JE::LValue' and
			ref base $term eq '' and
			return _new JE::String $global, 'undefined';
		_new JE::String $global, typeof $term;
	};
	*{'pre++'} = sub {
		# ~~~ These is supposed to use the same rules
		#     as the + infix op for the actual
		#     addition part. Verify that it does this.
		my $term = shift;
		$term->set(new JE::Number $global,
			get $term->to_number + 1);
	};
	*{'pre--'} = sub {
		# ~~~ These is supposed to use the same rules
		#     as the - infix op for the actual
		#     subtraction part. Verify that it does this.
		my $term = shift;
		$term->set(new JE::Number $global,
			get $term->to_number->value - 1);
	};
	*{'pre+'} = sub {
		shift->to_number;
	};
	*{'pre-'} = sub {
		new JE::Number $global, -shift->to_number->value;
	};
	*{'pre~'} = sub {
		my $num = shift->to_number->value;
		$num =
			$num != $num || abs($num) == inf  # nan/+-inf
			? 0
			: int($num) % 2**32;

		$num -= 2**32 if $num >= 2**31;

		{ use integer; # for signed bitwise negation
		  $num = ~$num; }

		new JE::Number $global, $num;
	};
	*{'pre!'} = sub {
		new JE::Boolean $global, !shift->to_boolean->value
	};
	*{'in*'} = sub {
		new JE::Number $global,
			shift->to_number->value *
			shift->to_number->value;
	};
	*{'in/'} = sub {
		my($num,$denom) = map to_number $_->value, @_[0,1];
		new JE::Number $global,
			$denom ?
				$num/$denom :
			# Divide by zero:
			$num && $num == $num # not zero or nan
				? $num * inf
				: nan;
	};
	*{'in%'} = sub {
		my($num,$denom) = map to_number $_->value,
			@_[0,1];
		new JE::Number $global,
			$num+1 == $num ? nan :
			$num == $num && abs($denom) == inf ?
				$num :
			fmod $num, $denom;
	};
	*{'in+'} = sub {
		my($x, $y) = @_;
		$x = $x->to_primitive;
		$y = $y->to_primitive;
		if($x->typeof eq 'string' or
		   $y->typeof eq 'string') {
			return _new JE::String $global,
				$x->to_string->value16 .
				$y->to_string->value16;
		}
		return new JE::Number $global,
		                      $x->to_number->value +
		                      $y->to_number->value;
	};
	*{'in-'} = sub {
		new JE::Number $global,
			shift->to_number->value -
			shift->to_number->value;
	};
	*{'in<<'} = sub {
		my $num = shift->to_number->value;
		$num =
			$num != $num || abs($num) == inf  # nan/+-inf
			? $num = 0
			: int($num) % 2**32;
		$num -= 2**32 if $num >= 2**31;

		my $shift_by = shift->to_number->value;
		$shift_by =
			$shift_by != $shift_by || abs($shift_by) == inf
			? 0
			: int($shift_by) % 32;

		my $ret = ($num << $shift_by) % 2**32;
		$ret -= 2**32 if $ret >= 2**31;

		new JE::Number $global, $ret;

		# Fails on 64-bit:
		#use integer;
		#new JE::Number $global,
		#	$num << $shift_by;
	};
	*{'in>>'} = sub {
		my $num = shift->to_number->value;
		$num =
			$num != $num || abs($num) == inf  # nan/+-inf
			? $num = 0
			: int($num) % 2**32;
		$num -= 2**32 if $num >= 2**31;

		my $shift_by = shift->to_number->value;
		$shift_by =
			$shift_by != $shift_by || abs($shift_by) == inf
			? 0
			: int($shift_by) % 32;

		use integer;
		new JE::Number $global,
			$num >> $shift_by;
	};
	*{'in>>>'} = sub {
		my $num = shift->to_number->value;
		$num =
			$num != $num || abs($num) == inf  # nan/+-inf
			? $num = 0
			: int($num) % 2**32;

		my $shift_by = shift->to_number->value;
		$shift_by =
			$shift_by != $shift_by || abs($shift_by) == inf
			? 0
			: int($shift_by) % 32;

		new JE::Number $global,
			$num >> $shift_by;
	};
	*{'in<'} = sub {
		my($x,$y) = map to_primitive $_, @_[0,1];
		new JE::Boolean $global,
			$x->typeof eq 'string' &&
			$y->typeof eq 'string'
			? $x->to_string->value16 lt $y->to_string->value16
			: $x->to_number->[0] <  $y->to_number->[0];
	};
	*{'in>'} = sub {
		my($x,$y) = map to_primitive $_, @_[0,1];
		new JE::Boolean $global,
			$x->typeof eq 'string' &&
			$y->typeof eq 'string'
			? $x->to_string->value16 gt $y->to_string->value16
			: $x->to_number->[0] >  $y->to_number->[0];
	};
	*{'in<='} = sub {
		my($x,$y) = map to_primitive $_, @_[0,1];
		new JE::Boolean $global,
			$x->typeof eq 'string' &&
			$y->typeof eq 'string'
			? $x->to_string->value16 le $y->to_string->value16
			: $x->to_number->[0] <= $y->to_number->[0];
	};
	*{'in>='} = sub {
		my($x,$y) = map to_primitive $_, @_[0,1];
		new JE::Boolean $global,
			$x->typeof eq 'string' &&
			$y->typeof eq 'string'
			? $x->to_string->value16 ge $y->to_string->value16
			: $x->to_number->[0] >= $y->to_number->[0];
	};
	*{'ininstanceof'} = sub {
		my($obj,$func) = @_;
		die new JE::Object::Error::TypeError $global,
			add_line_number "$func is not an object"
			if $func->primitive;

		die new JE::Object::Error::TypeError $global,
			add_line_number "$func is not a function"
			if $func->typeof ne 'function';

		return new JE::Boolean $global, 0 if $obj->primitive;

		my $proto_id = $func->prop('prototype');
		!defined $proto_id || $proto_id->primitive and die new
		   JE::Object::Error::TypeError $global,
		   add_line_number "Function $$$func{func_name} has no prototype property";
		$proto_id = $proto_id->id;

		0 while (defined($obj = $obj->prototype)
		         or return new JE::Boolean $global, 0),
			$obj->id ne $proto_id;

		new JE::Boolean $global, 1;
	};
	*{'inin'} = sub {
		my($prop,$obj) = @_;
		die new JE::Object::Error::TypeError $global,
		    add_line_number "$obj is not an object"
			if $obj->primitive;
		new JE::Boolean $global, defined $obj->prop($prop);
	};
	*{'in=='} = sub {
		my($x,$y) = @_;
		my($xt,$yt) = (typeof $x, typeof $y);
		my($xi,$yi) = (    id $x,     id $y);
		$xt eq $yt and return new JE::Boolean $global,
			$xi eq $yi && $xi ne 'num:nan';

		$xi eq 'null' and
			return new JE::Boolean $global,
				$yi eq 'undef';
		$xi eq 'undef' and
			return new JE::Boolean $global,
				$yi eq 'null';
		$yi eq 'null' and
			return new JE::Boolean $global,
				$xi eq 'undef';
		$yi eq 'undef' and
			return new JE::Boolean $global,
				$xi eq 'null';

		if($xt eq 'boolean') {
			$x = to_number $x;
			$xt = 'number';
		}
		elsif($yt eq 'boolean') {
			$y = to_number $y;
			$yt = 'number';
		}

		if($xt eq 'string' || $xt eq 'number' and !primitive $y)
			{ $y = to_primitive $y; $yt = typeof $y }
		elsif
		  ($yt eq 'string' || $yt eq 'number' and !primitive $x)
			{ $x = to_primitive $x; $xt = typeof $x }

		($xt eq 'number' and $yt eq 'string' || $yt eq 'number')
		  ||
		($yt eq 'number' and $xt eq 'string' || $xt eq 'number')
		  and
			return new JE::Boolean $global,
			to_number $x->[0] == to_number $y->[0];

		$xt eq 'string' && $yt eq 'string' and
			return new JE::Boolean $global,
			$x->value16 eq $y->value16;

		new JE::Boolean $global, 0;
	};
	*{'in!='} = sub {
		new JE::Boolean $global, !&{'in=='}->[0];
	};
	*{'in==='} = sub {
		my($x,$y) = @_;
		my($xi,$yi) = (    id $x,     id $y);
		return new JE::Boolean $global,
			$xi eq $yi && $xi ne 'num:nan';
	};
	*{'in!=='} = sub {
		new JE::Boolean $global, !&{'in==='}->[0];
	};

	# ~~~ These three bitwise operators are slower than molasses. There
	# must be some way to speed them up, but I'm not sure the research
	# is worth it. Does anyone actually use these in JS?
	*{'in&'} = sub {
		my $num = shift->to_number->[0];
		$num =
			$num != $num || abs($num) == inf
			? 0
			: int($num) % 2**32;
		$num -= 2**32 if $num >= 2**31;

		my $num2 = shift->to_number->[0];
		$num2 =
			$num2 != $num2 || abs($num2) == inf
			? 0
			: int($num2) % 2**32;
		$num2 -= 2**32 if $num2 >= 2**31;

		use integer;
		new JE::Number $global,
			$num & $num2;
	};
	*{'in^'} = sub {
		my $num = shift->to_number->[0];
		$num =
			$num != $num || abs($num) == inf
			? 0
			: int($num) % 2**32;
		$num -= 2**32 if $num >= 2**31;

		my $num2 = shift->to_number->[0];
		$num2 =
			$num2 != $num2 || abs($num2) == inf
			? 0
			: int($num2) % 2**32;
		$num2 -= 2**32 if $num2 >= 2**31;

		use integer;
		new JE::Number $global,
			$num ^ $num2;
	};
	*{'in|'} = sub {
		my $num = shift->to_number->[0];
		$num =
			$num != $num || abs($num) == inf
			? 0
			: int($num) % 2**32;
		$num -= 2**32 if $num >= 2**31;

		my $num2 = shift->to_number->[0];
		$num2 =
			$num2 != $num2 || abs($num2) == inf
			? 0
			: int($num2) % 2**32;
		$num2 -= 2**32 if $num2 >= 2**31;

		use integer;
		new JE::Number $global,
			$num | $num2;
	};
}

=begin for-me

Types of expressions:

'new' term args?

'member/call' term ( subscript | args) *

'postfix' term op

'hash' term*

'array' term? (comma term?)*

'prefix' op+ term

'lassoc' term (op term)*

'assign' term (op term)* (term term)?
	(the last two terms are the 2nd and 3rd terms of ? :

'expr' term*
	(commas are omitted from the array)

'function' ident? params statements

=end for-me

=cut


# Note: each expression object is an array ref. The elems are:
# [0] - an array ref containing
#       [0] - the starting position in the source code and
#       [1] - the ending position
# [1] - the type of expression
# [2..$#] - the various terms/tokens that make up the expr

sub eval {  # evalate (sub)expression
	no warnings 'exiting';
	++ $ops>$counting and last JE_Code_OP  if $counting;

	my $expr = shift;

	my $type = $$expr[1];
	my @labels;

	$pos = $$expr[0][0];

	if ($type eq 'expr') {
		my $result;
		if(@$expr == 3) { # no comma
			return _eval_term $$expr[-1];
		}
		else { # comma op
			for (@$expr[2..$#$expr-1]) {
				$result = _eval_term $_ ;
				get $result if ref $result eq 'JE::LValue';
			}
			$result = _eval_term $$expr[-1] ;
			return ref $result eq 'JE::LValue' ? get $result
				: $result;
		}
	}
	if ($type eq 'assign') {
		my @copy = \(@$expr[2..$#$expr]);
		# Evaluation is done left-first in JS, unlike in
		# Perl, so a = b = c is evaluated in this order:
		#  - evaluate a
		#  - evaluate b
		#  - evaluate c
		#  - assign c to b
		#  - assign b to a

		# Check first to see whether we have the terms
		# of a ? : at the end:
		my @qc_terms = @copy >= 3 && (
				ref ${$copy[-2]} # avoid stringification
				|| ${$copy[-2]} =~ /^(?:[tfu]|[si0-9])/
		)
			? (pop @copy, pop @copy) : ();
			# @qc_terms is now in reverse order

		# Make a list of operands, evalling each
		my @terms = _eval_term ${shift @copy};
		my @ops;
		while(@copy) {
			push @ops, ${shift @copy};
			push @terms, _eval_term ${shift @copy};
		}

		my $val = pop @terms;

		# Now apply ? : if it's there
		@qc_terms and $val = _eval_term
			${$qc_terms[$val->to_boolean->[0]]};

		for (reverse @ops) {
			no strict 'refs';
			length > 1 and $val =
				&{'in'.substr $_,0,-1}(
					$terms[-1], $val
				);
			$val = $val->get if ref $val eq 'JE::LValue';
			T and tainted $taint and $val->can('taint')
				and $val = taint $val $taint;
			eval { (pop @terms)->set($val) };
			if (my $err = $@) {
				die $err if UNIVERSAL::isa($err, 'JE::Object::Error');
				die new JE::Object::Error::ReferenceError
					$global, add_line_number "Cannot assign to a non-lvalue";
			}
			# ~~~ This needs to check whether it was an error
			#     other than 'Can't locate object method "set"
			#     since store handlers can thrown other errors.

		}
		if(!@ops) { # If we only have ? : and no assignment
			$val = $val->get if ref $val eq 'JE::LValue';
		}
		return $val;
	}
	if($type eq 'lassoc') { # left-associative
		my @copy = \(@$expr[2..$#$expr]);
		my $result = _eval_term ${shift @copy};
		while(@copy) {
			no strict 'refs';
			# We have to deal with || && here for the sake of
			# short-circuiting
			my $op = ${$copy[0]};
			if ($op eq '&&') {
				$result = _eval_term(${$copy[1]}) if
					$result->to_boolean->[0];
				$result = $result->get
					if ref $result eq 'JE::LValue';
			}
			elsif($op eq '||') {
				$result = _eval_term(${$copy[1]}) unless
					$result->to_boolean->[0];
				$result = $result->get
					if ref $result eq 'JE::LValue';
			}
			else {
				$result = $result->get
					if ref $result eq 'JE::LValue';
				$result = &{"in$op"}(
					$result, _eval_term ${$copy[1]}
				);
			}
			splice @copy, 0, 2; # double shift
		}
		return $result;
	}
	if ($type eq 'prefix') {
		# $$expr[1]     -- 'prefix'
		# @$expr[2..-2] -- prefix ops
		# $$expr[-1]    -- operand
		my $term = _eval_term $$expr[-1];

		no strict 'refs';
		$term = &{"pre$_"}($term) for reverse @$expr[2..@$expr-2];
		return $term;
	}
	if ($type eq 'postfix') {
		# ~~~ These are supposed to use the same rules
		#     as the + and - infix ops for the actual
		#     addition part. Verify that they do this.

		my $ret = (my $term = _eval_term $$expr[2])
			->to_number;
		$term->set(new JE::Number $global,
			$ret->value + (-1,1)[$$expr[3] eq '++']);
		return $ret;
	}
	if ($type eq 'new') {
		return _eval_term($$expr[2])->construct(
			@$expr == 4
			? T && tainted $taint
				? map $_->can('taint') ?taint $_ $taint:$_,
					$$expr[-1]->list
				: $$expr[-1]->list
			: ()
		);
	}
	if($type eq 'member/call') {
		my $obj = _eval_term $$expr[2];
		for (@$expr[3..$#$expr]) {
			if(ref eq 'JE::Code::Subscript') {
				$obj = get $obj
					if ref $obj eq 'JE::LValue';
				$obj = new JE::LValue $obj, $_->str_val;
			}
			else {
				$obj = $obj->call(
					T && tainted $taint
					? map $_->can('taint')
						? taint $_ $taint
						: $_,
					  $_->list
					: $_->list
				);
				# If $obj is an lvalue,
				# JE::LValue::call will make
				# the lvalue's base object the 'this'
				# value. Otherwise,
				# JE::Object::Function::call
				# will make the
				# global object the 'this' value.
			}
			# ~~~ need some error-checking
		}
		return $obj; # which may be an lvalue
	}
	if($type eq 'array') {
		my @ary;
		for (2..$#$expr) {
			if(ref $$expr[$_] eq 'comma') {
				ref $$expr[$_-1] eq 'comma' || $_ == 2
				and ++$#ary
			}
			else {
				push @ary, _eval_term $$expr[$_];
				$ary[-1] = $ary[-1]->get
				 if ref $ary[-1] eq 'JE::LValue';
			}
		}

		my $ary = new JE::Object::Array $global;
		$$$ary{array} = \@ary; # sticking it in like this
		                       # makes 'undef' elements non-
		                       # existent, rather
		                       # than undefined
		return $ary;
	}
	if($type eq 'hash') {
		my $obj = new JE::Object $global;
		local @_ = \(@$expr[2..$#$expr]);
		my (@keys, $key, $value);
		while(@_) { # I have to loop through them to keep
		            # the order.
			$key = ${+shift};
			$value = _eval_term ${shift;};
			$value = get $value if ref $value eq 'JE::LValue';
			$obj->prop($key, $value);
		}
		return $obj;
	}
	if ($type eq 'func') {
		# format: [[...], function=> 'name',
		#          [ params ], $statements_obj, \@vars]
		#     or: [[...], function =>
		#          [ params ], $statements_obj, \@vars]
		my($name,$params,$statements) = ref $$expr[2] ?
			(undef, @$expr[2,3]) : @$expr[2..4];
		my $func_scope = $name
			? bless([@$scope, my $obj=new JE::Object $global],
				'JE::Scope')
			: $scope;
		(my $new_code_obj = bless {
			map+($_=>$code->{$_}),qw/global source file line/
		}, 'JE::Code')
		 ->{tree} = $statements;
		$new_code_obj->{vars} = $$expr[-1];
		my $f = new JE::Object::Function {
			scope    => $func_scope,
			defined $name ? (name => $name) : (),
			argnames => $params,
			function => $new_code_obj,
		};
		if($name) {
			$obj->prop({
				name    => $name,
				value   => $f,
				readonly => 1,
				dontdel  => 1,
			});
		}
		return $f;
	}
}
sub _eval_term {
	my $term = $_[0];

	return $term->eval if ref $term eq 'JE::Code::Expression';

	ref $term     ? ref $term eq 'ARRAY'
	                ? ( require JE::Object::RegExp,
	                    return JE::Object::RegExp->new(
	                      $global, @$term
	                    ) )
	                : $term :
	$term eq'this'? $this :
	$term =~ /^s/ ? $_[0] = JE::String->_new($global,substr $term,1) :
	$term =~ /^i/ ? $scope->find_var(substr $term,1) :
	$term eq 't'  ? $global->true :
	$term eq 'f'  ? $global->false :
	$term eq 'n'  ? $global->null :
	               ($_[0] = JE::Number->new($global,$term));
}




package JE::Code::Subscript;

our $VERSION = '0.066';

sub str_val {
	my $val = (my $self = shift)->[1];
	ref $val ? ''.$val->eval : $val;
}




package JE::Code::Arguments;

our $VERSION = '0.066';

sub list {
	my $self = shift;

	#  I can't use map here, because this method is called from within
	#  a foreach loop,  and an exception might be thrown from  within
	# _eval_term, which has strange effects in perl 5.8.x (see perl
	#  bug #24254).

if(1) {
	my @result;
	for(@$self[1..$#$self]) {
		my $val = JE::Code::Expression::_eval_term($_);
		push @result, ref $val eq 'JE::LValue' ? $val->get : $val
	}
	@result;

}else{ # original code
	map { my $val = JE::Code::Expression::_eval_term($_);
	      ref $val eq 'JE::LValue' ? $val->get : $val }
	    @$self[1..$#$self];
}
}




1;
__END__