JE::LValue - JavaScript lvalue class

  use JE::LValue;

  $lv = new JE::LValue $some_obj, 'property_name';

  $lv->get;         # get property
  $lv->set($value)  # set property

  $lv->some_other_method  # same as $lv->get->some_other_method

package JE::LValue;

our $VERSION = '0.54';

use strict;
use warnings; no warnings 'utf8';

use List::Util 'first';
use Scalar::Util 'blessed';

require JE::Code;
require JE::Object::Error::TypeError;
require JE::Object::Error::ReferenceError;

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


our $ovl_infix = join ' ', @overload::ops{qw[
	with_assign assign num_comparison 3way_comparison str_comparison	binary
]};
our $ovl_prefix = join ' ', grep !/^(?:neg|atan2)\z/,
	map split(/ /), @overload::ops{qw[ unary mutators func ]};

use overload
fallback => !1,
nomethod => sub {
	my $at = $@;
	my ($self, $other, $reversed, $symbol) = @_;
	return $self if $symbol eq '=';
	$self = $self->get;
	my $sym_regexp = qr/(?:^| )\Q$symbol\E(?:$| )/;
	my $val;
	if ($overload::ops{conversion} =~ $sym_regexp) {
		return $self;
	}
	elsif($ovl_infix =~ $sym_regexp) {
		my $bits = (caller 0)[9];
		$val = eval 'BEGIN{${ARNING_BITS} = $bits}'
		         . ( $reversed ? "\$other $symbol \$self"
		                       : "\$self $symbol \$other" );
	}
	elsif($ovl_prefix =~ $sym_regexp) {
		my $bits = (caller 0)[9];
		$val
		 = eval "BEGIN{\${ARNING_BITS} = \$bits}$symbol \$self";
	}
	elsif($symbol eq 'neg') {
		return -$self;
	}
	elsif($symbol eq 'atan2') {
		return atan2 $self, $other;
	}
	elsif($symbol eq '<>') {
		return <$self>;
	}
	else {
		die "Oh no! Something is terribly wrong with " .
		    "JE::LValue's overloading mechanism. It can't deal " .
		    "with < $symbol >. Please send a bug report.";
	}
	$@ and die $@;
	$@ = $at;
	return $val;
},
'@{}' => sub {
	caller eq __PACKAGE__ and return shift;	
	$_[0]->get;
},
'%{}' => 'get', '&{}' => 'get', '*{}' => 'get', '${}' => 'get';

sub new {
	my ($class, $obj, $prop) = @_; # prop is a string
	if(defined blessed $obj && can $obj 'id'){
		my $id = $obj->id;
		$id eq 'null' || $id eq 'undef' and die 
			new JE::Object::Error::TypeError $obj->global,
			add_line_number
			    $obj->to_string->value . " has no properties"
			    .", not even one named $prop";
	}
	bless [$obj, $prop], $class;
}

sub get {
	my $base = (my $self = shift)->[0];
	defined blessed $base or die new 
		JE::Object::Error::ReferenceError $$base, add_line_number 
		"The variable $$self[1] has not been declared";
		
	my $val = $base->prop($self->[1]);
	defined $val ? $val : $base->global->undefined;
		# If we have a Perl undef, then the property does not
		# not exist, and we have to return a JS undefined val.
}

sub set {
	my $obj = (my $self = shift)->[0];
	defined blessed $obj or $obj = $$self[0] = $$obj;
	$obj->prop($self->[1], shift);
}

sub call {
	my $base_obj = (my $self = shift)->[0];
	my $prop = $self->get; # dies here if $base_obj is not blessed
	defined $prop or
		die new JE::Object::Error::TypeError $base_obj->global,
		add_line_number "The object's '" . $self->[1] .
			"' property (undefined) is not a function";
	$prop->can('apply') or
		die new JE::Object::Error::TypeError $base_obj->global,
		add_line_number "The object's '" . $self->[1] .
			"' property ($prop) is not a function";
	$prop->apply($base_obj, @_);
}

sub base { 
	my $base = $_[0][0];
	defined blessed $base ? $base : ()
}

sub property { shift->[1] }

our $AUTOLOAD;

sub AUTOLOAD {
	my($method) = $AUTOLOAD =~ /([^:]+)\z/;

	return if $method eq 'DESTROY';

#my $l = $_[0]; my $ret, my @ret;;
no warnings 'uninitialized';
#eval {
# $ret =	
return shift->get->$method(@_); # ~~~ Maybe I should use goto
	                         #     to remove AUTOLOAD from
	                         #     the call stack.
#1} or die add_line_number $l->base . ' ' . $l->property . ' ' . $l->get . #' ' . ref $_->get . qq': $@';
#return $ret;
}

sub can { # I think this returns a *canned* lvalue, as opposed to a fresh
          # one. :-)
	
	!ref $_[0] || $_[1] eq 'DESTROY' and goto &UNIVERSAL::can;

	&UNIVERSAL::can || do {
	                        my $sub = (my $obj = shift->get)->can(@_)
	                         or return undef;
	                        sub { splice @'_, 0, 1, $obj; goto &$sub }
	                      };
}

1;