JE::Object - Base class for all JavaScript objects

  use JE;
  use JE::Object;

  $j = new JE;

  $obj = new JE::Object $j;

  $obj->prop('property1', $new_value);  # sets the property
  $obj->prop('property1');              # returns $new_value;
  $obj->{property1} = $new_value;       # or use it as a hash
  $obj->{property1};                    # ref like this

  $obj->keys; # returns a list of the names of enumerable property
  keys %$obj;

  $obj->delete('property_name');
  delete $obj->{property_name};

  $obj->method('method_name', 'arg1', 'arg2');
    # calls a method with the given arguments

  $obj->value ;    # returns a value useful in Perl (a hashref)

  "$obj";  # "[object Object]" -- same as $obj->to_string->value
  0+$obj"; #  nan -- same as $obj->to_number->value
  # etc.

  %$obj = (); # no good!

  $obj->{a}{b} = 3;

  $$self->{global}         a reference to the global object
  $$self->{props}          a hash ref of properties, the values being
                           JavaScript objects
  $$self->{prop_readonly}  a hash ref with property names for the keys
                           and booleans  (that indicate  whether  prop-
                           erties are read-only) for the values
  $$self->{prop_dontdel}   a hash ref in the same format as
                           prop_readonly that indicates whether proper-
                           ties are undeletable
  $$self->{keys}           an array of the names of enumerable
                           properties
  $$self->{prototype}      a reference to this object's prototype

package JE::Object;

# This has to come before any pragmas and sub declarations.
sub evall { my $global = shift; my $r = eval 'local *_;' . shift;
            $@ and die; $r }

our $VERSION = '0.042';

use strict;
use warnings;

use overload fallback => 1,
	'%{}'=>  \&_get_tie,
	'""' => 'to_string',
        '0+' => 'to_number',
#	 cmp =>  sub { "$_[0]" cmp $_[1] },
	bool =>  sub { 1 };

use Scalar::Util qw'refaddr blessed';
use List::Util 'first';
use B 'svref_2object';
#use Data::Dumper;


require JE::Code;
require JE::Object::Error::TypeError;
require JE::Object::Function;
require JE::Boolean;
require JE::String;

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

sub in_list { 
	my $str = shift;
	shift eq $str and return 1 while @_;
	!1;
}

# ~~~ Perhaps I should eliminate the hash ref syntax and have new()
#     check to see if $j->exists($class->class), and use that as the
#     prototype. That would make the other constructors simpler, but would
#     it make it harder to control JE and customise host objects?

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

	if (defined blessed $value
	    and can $value 'to_object') {
		return to_object $value;
	}
	
	my $p;
	my %hash;
	my %opts;

	ref $value eq 'HASH' and (%opts = %$value), $value = $opts{value};
	
	local $@;
	if (!defined $value || !defined eval{$value->value} && $@ eq '') {
		$p = exists $opts{prototype} ? $opts{prototype}
		      : $global->prototype_for("Object");
	}
	elsif(ref $value eq 'HASH') {
		%hash = %$value;
		$p = $global->prototype_for("Object");
	}
	else {
		return $global->upgrade($value);
	}

	bless \{ prototype => $p,
	         global    => $global,
	         props     => \%hash,
	         keys      => [keys %hash]  }, $class;
}

sub new_function {
	my $self = shift;
	my $f = JE::Object::Function->new({
		scope   => $self->global,
		function   => pop,
		function_args => ['args'],
		@_ ? (name => $_[0]) : ()
	});
	@_ and $self->prop({
		name => shift,
		value=>$f,
	});
	$f;
}

sub new_method {
	my $self = shift;
	my $f = JE::Object::Function->new({
		scope   => $self->global,
		function   => pop,
		function_args => ['this','args'],
		@_ ? (name => $_[0]) : ()
	});
	@_ and $self->prop({
		name => shift,
		value=>$f,
		dontenum=>1
	});
	$f;
}

sub prop {
	my ($self, $opts) = (shift, shift);
	my $guts = $$self;

	if(ref $opts eq 'HASH') { # special use
		my $name = $$opts{name};
		for (qw< dontdel readonly >) {
			exists $$opts{$_}
				and $$guts{"prop_$_"}{$name} = $$opts{$_};
		}

		my $props = $$guts{props};

		my $dontenum;
		if(exists $$opts{dontenum}) {
			if($$opts{dontenum}) {
				@{$$guts{keys}} = 
					grep $_ ne $name, @{$$guts{keys}};
			}
			else {
				push @{ $$guts{keys} }, $name
			    	unless first {$_ eq $name} @{$$guts{keys}};
			}
		}
		elsif(!exists $$props{$name}) { # new property
			push @{ $$guts{keys} }, $name
		}

		if(exists $$opts{fetch}) {
			$$guts{fetch_handler}{$name} = $$opts{fetch};
			$$props{$name} = undef if !exists $$props{$name};
		}
		if(exists $$opts{store}) {
			$$guts{store_handler}{$name} = $$opts{store};
			$$props{$name} = undef if !exists $$props{$name};
		}
		if(exists $$opts{value}) {
			return $$props{$name} = $$opts{value};
		}
		elsif(!exists $$opts{fetch} && exists $$opts{autoload}) {
			my $auto = $$opts{autoload};
			$$props{$name} = ref $auto eq 'CODE' ? $auto :
				"package " . caller() . "; $auto";
			return # ~~~ Figure out what this should
			       #     return, if anything
		}

		# ~~~ what should we return if fetch is given,
		#     but not value?

		return exists $$opts{fetch} ? () :
		       exists $$props{$name} ? $$props{$name} : undef;
	}

	else { # normal use
		my $name = $opts;
		my $props = $$guts{props};
		if (@_) { # we is doing a assignment
			my($new_val) = shift;

			return $new_val if $self->is_readonly($name);

			# Make sure we don't change attributes if the
			# property already exists
			my $exists = exists $$props{$name} &&
				defined $$props{$name};

			exists $$guts{store_handler}{$name}
			? $$guts{store_handler}{$name}->(
				$self, $new_val, $$props{$name})
			: ($$props{$name} = $new_val);

			push @{ $$guts{keys} }, $name
			    unless $exists; 

			return $new_val;
		}
		elsif (exists $$props{$name}) {
			if(exists $$guts{fetch_handler}{$name}) {
				return $$guts{fetch_handler}{$name}-> (
					$self, $$props{$name}
				);
			}

			my $val = $$props{$name};
			ref $val eq 'CODE' ?
				$val = $$props{$name} = &$val() :
			defined $val && ref $val eq '' &&
				($val = $$props{$name} =
					evall $$guts{global}, $val
				);
			return $val;
		}
		else {
			my $proto = $self->prototype;
			return $proto ?
				$proto->prop($name) :
				undef;
		}	
	}

}


sub exists { # = hasOwnProperty
	my($self,$name) = @_;
	return exists $$$self{props}{$name}
}


sub is_readonly { # See JE::Types for a description of this.
	my ($self,$name) = (shift,@_);  # leave $name in @_

	my $guts = $$self;

	my $props = $$guts{props};
	if( exists $$props{$name}) {
		my $read_only_list = $$guts{prop_readonly};
		return exists $$read_only_list{$name} ?
			$$read_only_list{$name} : !1;
	}

	if(my $proto = $self->prototype) {
		return $proto->is_readonly(@_);
	}

	return !1;
}




sub is_enum {
	my ($self, $name) = @_;
	$self = $$self;
	in_list $name, @{ $$self{keys} };
}




sub keys {
	my $self = shift;
	my $proto = $self->prototype;
	@{ $$self->{keys} }, defined $proto ? $proto->keys : ();
}

sub delete {
	my ($self, $name) = @_;
	my $guts = $$self;

	unless($_[2]) { # second arg means always delete
		my $dontdel_list = $$guts{prop_dontdel};
		exists $$dontdel_list{$name} and $$dontdel_list{$name}
			and return !1;
	}
	
	delete $$guts{prop_dontdel }{$name};
	delete $$guts{prop_dontenum}{$name};
	delete $$guts{prop_readonly}{$name};
	delete $$guts{props}{$name};
	$$guts{keys} = [ grep $_ ne $name, @{$$guts{keys}} ];
	return 1;
}




sub method {
	my($self,$method) = (shift,shift);

	$self->prop($method)->apply($self, $self->global->upgrade(@_));
}

sub typeof { 'object' }

sub class { 'Object' }

sub value {
	my $self = shift;
	+{ map +($_ => $self->prop($_)), $self->keys };
}




sub id {
	refaddr shift;
}

sub primitive { !1 };

sub prototype {
	@_ > 1 ? (${+shift}->{prototype} = $_[1]) : ${+shift}->{prototype};
}




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

	my @methods = ('valueOf','toString');
	defined $hint && $hint eq 'string' and @methods = reverse @methods;

	my $method; my $prim;
	for (@methods) {
		defined($method = $self->prop($_)) || next;
		($prim = $method->apply($self))->primitive || next;
		return $prim;
	}

	die new JE::Object::Error::TypeError $self->global,
	  add_line_number "An object of type " .
		(eval {$self->class} || ref $self) .
		" cannot be converted to a primitive";
}




sub to_boolean { 
	JE::Boolean->new( $${+shift}{global}, 1 );
}

sub to_string {
	shift->to_primitive('string')->to_string;
}


sub to_number {
	shift->to_primitive('number')->to_number;
}

sub to_object { $_[0] }

sub global { ${+shift}->{global} }

sub new_constructor {
	my($package,$global,$function,$init_proto) = @_;

	my $f = JE::Object::Function->new({
		name            => $package->class,
		scope            => $global,
		function         => $function,
		function_args    => ['scope','args'],
		constructor      => sub {
			no strict 'refs';
			$package->new(@_);
		},
		constructor_args => ['scope','args'],
	});

	my $proto = $f->prop({
		name    => 'prototype',
		dontenum => 1,
		readonly => 1,
	});

	$init_proto and &$init_proto($proto);

	$f;
}

#----------- PRIIVATE ROUTIES ---------------#

# _init_proto takes the Object prototype (Object.prototype) as its sole
# arg and adds all the default properties thereto.

sub _init_proto {
	my $proto = shift;
	my $global = $$proto->{global};

	# E 15.2.4

	$proto->prop({
		dontenum => 1,
		name => 'constructor',
		value => $global->prop('Object'),
	});

	my $toString_sub = sub {
		my $self = shift;
		JE::String->new($global,
			'[object ' . $self->class . ']');
	};

	$proto->prop({
		name      => 'toString',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'toString',
			length   => 0,
			function_args => ['this'],
			function => $toString_sub,
			no_proto => 1,
		}),
		dontenum  => 1,
	});

	$proto->prop({
		name      => 'toLocaleString',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'toLocaleString',
			length   => 0,
			function_args => ['this'],
			function => sub { shift->method('toString') },
			no_proto => 1,
		}),
		dontenum  => 1,
	});

	$proto->prop({
		name      => 'valueOf',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'valueOf',
			length   => 0,
			function_args => ['this'],
			function => sub { $_[0] },
			no_proto => 1,
		}),
		dontenum  => 1,
	});

	$proto->prop({
		name      => 'hasOwnProperty',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'hasOwnProperty',
			argnames => ['V'],
			function_args => ['this', 'args'],
			function => sub {
				JE::Boolean->new($global, 
				    shift->exists(
				        defined $_[0] ? $_[0] : 'undefined'
				    )
				);
			},
			no_proto => 1,
		}),
		dontenum  => 1,
	});

	$proto->prop({
		name      => 'isPrototypeOf',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'isPrototypeOf',
			argnames => ['V'],
			function_args => ['this', 'args'],
			function => sub {
				my ($self, $obj) = @_;

				!defined $obj || $obj->primitive and return 
					JE::Boolean->new($global, 0);

				my $id = $self->id;
				my $proto = $obj;

				while (defined($proto = $proto->prototype))
				{
					$proto->id eq $id and return
					    JE::Boolean->new($global, 1);
				}

				return JE::Boolean->new($global, 0);
			},
			no_proto => 1,
		}),
		dontenum  => 1,
	});

	$proto->prop({
		name      => 'propertyIsEnumerable',
		value     => JE::Object::Function->new({
			scope    => $global,
			name     => 'propertyIsEnumerable',
			argnames => ['V'],
			function_args => ['this', 'args'],
			function => sub {	
				return JE::Boolean->new($global,
				    shift->is_enum(
				        defined $_[0] ? $_[0] : 'undefined'
				    )
				);
			},
			no_proto => 1,
		}),
		dontenum  => 1,
	});
}



#----------- TYING MAGIC ---------------#

# I'm putting the object itself behind the tied hash, so that no new object
# has to be created.
# That means that tied %$obj returns $obj.


sub _get_tie {
	my $self = shift;
	my $guts = $$self;
	$$guts{tie} or tie %{ $$guts{tie} }, __PACKAGE__, $self;	
	$$guts{tie};
}

sub TIEHASH  { $_[1] }
sub FETCH    { $_[0]->prop($_[1]) }
sub STORE    {
	my($self, $key, $val) = @_;
	my $global = $self->global;
	if(ref $val eq 'HASH' && !blessed $val
  	   && !%$val && svref_2object($val)->REFCNT == 2) {
		$val = tie %$val, __PACKAGE__, __PACKAGE__->new(
			$global);
	} elsif (ref $val eq 'ARRAY' && !blessed $val && !@$val && 
	         svref_2object($val)->REFCNT == 2) {
		require JE::Object::Array;
		$val = tie @$val, 'JE::Object::Array',
			JE::Object::Array->new($global);
	}
	$self->prop($key => $global->upgrade($val))
}
#sub CLEAR   {  }
	# ~~~ have yet to implement this
sub DELETE   {
	my $val = $_[0]->prop($_[1]);
	$_[0]->delete($_[1]);
	$val;
}
sub EXISTS   { $_[0]->exists($_[1]) }
sub FIRSTKEY { ($_[0]->keys)[0] }
sub NEXTKEY  {
	my @keys = $_[0]->keys;
	my $last = $_[1];
	for (0..$#keys) {
		if ($last eq $keys[$_]) {
			return $keys[$_+1]
		}
	}

	# ~~~ What *should* we do if the property has been
	#     deleted?
	# I think this means the iterator should have been reset (from the
	# user's point of view), so we'll start from the beginning.

	return $keys[0];
}

sub DDS_freeze { my $self = shift; delete $$$self{tie}; $self }


#----------- THE REST OF THE DOCUMENTATION ---------------#

1;