File Coverage

blib/lib/JE/Object/Proxy.pm

Criterion	Covered	Total	%
statement	113	120	94.1
branch	57	72	79.1
condition	14	35	40.0
subroutine	16	16	100.0
pod	3	7	42.8
total	203	250	81.2

package JE::Object::Proxy;

our $VERSION = '0.065';

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

# ~~~ delegate overloaded methods?

use JE::Code 'add_line_number';
use Scalar::Util 1.09 qw'refaddr';

require JE::Object;

our @ISA = 'JE::Object';


=head1 NAME

JE::Object::Proxy - JS wrapper for Perl objects

=head1 SYNOPSIS

  $proxy = new JE::Object::Proxy $JE_object, $some_Perl_object;

=cut




sub new {
	my($class, $global, $obj) = @_;

	my $class_info = $$$global{classes}{ref $obj};

	my $self = ($class eq __PACKAGE__ # allow subclassing
	            && ($$class_info{hash} || $$class_info{array})
			? __PACKAGE__."::Array" : $class)
		   ->JE::Object::new($global,
		{ prototype => $$class_info{prototype} });

	@$$self{qw/class_info value/} = ($class_info, $obj);

	while(my($name,$args) = each %{$$class_info{props}}) {
		$self->prop({ name => $name, @$args });
	}

	$self;
}




sub class { $${$_[0]}{class_info}{name} }




sub value { $${$_[0]}{value} }




sub id {
	refaddr $${$_[0]}{value};
}




sub to_primitive { # ~~~ This code should  probably  be  moved  to
                   #     &JE::bind_class for the sake of efficiency.
	my($self, $hint) = (shift, @_);

	my $guts = $$self;
	my $value = $$guts{value};
	my $class_info = $$guts{class_info};

	if(exists $$class_info{to_primitive}) {
		my $tp = $$class_info{to_primitive};
		if(defined $tp) {
			ref $tp eq 'CODE' and
				return $$guts{global}->upgrade(
					&$tp($value, @_)
				);
			($tp, my $type) = JE::_split_meth($tp);
			return defined $type
			?  $$guts{global}->_cast($value->$tp(@_),$type)
			:  $$guts{global}->upgrade($value->$tp(@_))
		} else {
			die add_line_number
				"The object ($$class_info{name}) cannot "
				. "be converted to a primitive";
		}
	} else {
		if(overload::Method($value,'""') ||
		   overload::Method($value,'0+') ||
		   overload::Method($value,'bool')){
			return $$guts{global}->upgrade("$value");
		}
		return SUPER::to_primitive $self @_;
	}
}



sub to_string {
	my($self, $hint) = (shift, @_);

	my $guts = $$self;
	my $value = $$guts{value};
	my $class_info = $$guts{class_info};

	if(exists $$class_info{to_string}) {
		my $tp = $$class_info{to_string};
		if(defined $tp) {
			ref $tp eq 'CODE' and
				return $$guts{global}->upgrade(
					&$tp($value, @_)
				)->to_string;
			($tp, my $type) = JE::_split_meth $tp;
			return ( defined $type
			  ?  $$guts{global}->upgrade($value->$tp(@_))
			  :  $$guts{global}->_cast($value->$tp(@_),$type)
			)->to_string
		} else {
			die add_line_number
				"The object ($$class_info{name}) cannot "
				. "be converted to a string";
		}
	} else {
		return SUPER::to_string $self @_;
	}
}




sub to_number {
	my($self, $hint) = (shift, @_);

	my $guts = $$self;
	my $value = $$guts{value};
	my $class_info = $$guts{class_info};

	if(exists $$class_info{to_number}) {
		my $tp = $$class_info{to_number};
		if(defined $tp) {
			ref $tp eq 'CODE' and
				return $$guts{global}->upgrade(
					&$tp($value, @_)
				)->to_number;
			($tp, my $type) = JE::_split_meth $tp;
			return ( defined $type
			  ?  $$guts{global}->upgrade($value->$tp(@_))
			  :  $$guts{global}->_cast($value->$tp(@_),$type)
			)->to_number
		} else {
			die add_line_number
				"The object ($$class_info{name}) cannot "
				. "be converted to a number";
		}
	} else {
		return SUPER::to_number $self @_;
	}
}




package JE::Object::Proxy::Array; # so this extra stuff doesn't slow down
our $VERSION = '0.065';           # 'normal' usage
our @ISA = 'JE::Object::Proxy';
require JE::Number;

sub prop {
	my $self = shift;
	my $wrappee = $self->value;
	my $name = shift;
	my $class_info = $$$self{class_info};

	if ($$class_info{array}) {
		if($name eq 'length') {
			@_ ? ($#$wrappee = $_[0]-1, return shift)
			   : return new JE::Number
			      $self->global, scalar @$wrappee
		}
		if($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295){
			@_ ? $$class_info{array}{store}(
				$wrappee,$name,$_[0]) && return shift
		  	 : do {
				my $ret =
				   $$class_info{array}{fetch}(
				      $wrappee,$name);
				defined $ret and return $ret;
			   }
		}
	}
	if ($$class_info{hash}and !exists $$class_info{props}{$name}) {
		if(@_){
			$$class_info{hash}{store}->(
				$wrappee,$name,$_[0]
			) and return shift;
		}else{
			my $ret = $$class_info{hash}{fetch}
				($wrappee,$name);
			defined $ret and return $ret;
		}
	}
	SUPER::prop $self $name, @_;
}

sub keys {
	my $self = shift;
	my $wrappee = $self->value;
	my $class_info = $$$self{class_info};
	my @keys;
	if ($$class_info{array}){
		@keys = grep(exists $wrappee->[$_], 0..$#$wrappee);
	}
	if($$class_info{hash}) {
		push @keys, keys %$wrappee;
	}
	push @keys, SUPER::keys $self;
	my @new_keys; my %seen;
	$seen{$_}++ or push @new_keys, $_ for @keys;
	@new_keys;
}

sub delete {
	my $self = shift;
	my $wrappee = $self->value;
	my($name) = @_;
	my $class_info = $$$self{class_info};
	if ($$class_info{array}){
		if ($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295 and
		    exists $wrappee->[$name]) {
			delete $wrappee->[$name];
			return !$self->exists($name);
		}
		elsif ($name eq 'length') {
			return !1
		}
	}
	if($$class_info{hash} && !exists $$class_info{props}{$name} and
	   exists $wrappee->{$name}) {
		delete $wrappee->{$name};
		return !exists $wrappee->{$name};
	}
	SUPER::delete $self @_;
}

sub exists {
	my $self = shift;
	my $wrappee = $self->value;
	my($name) = @_;
	my $class_info = $$$self{class_info};
	if ($$class_info{array}){
		if ($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295) {
			return 1 if exists $wrappee->[$name];
			# If it doesn’t exists, try hash keys below.
		}
		elsif ($name eq 'length') {
			return 1
		}
	}
	if($$class_info{hash}) {
	   return 1 if exists $wrappee->{$name};
	}
	SUPER::exists $self @_;

}


1;