JE::Object::Function - JavaScript function class

  use JE::Object::Function;

  # simple constructors:

  $f = new JE::Object::Function $scope, @argnames, $function;
  $f = new JE::Object::Function $scope, $function;

  # constructor that lets you do anything:

  $f = new JE::Object::Function {
          name             => $name,
          scope            => $scope,
          length           => $number_of_args,
          argnames         => [ @argnames ],
          function         => $function,
          function_args    => [ $arglist ],
          constructor      => sub { ... },
          constructor_args => [ $arglist ],
          downgrade        => 0,
  };




  $f->(@args);
  $f->call_with($obj, @args);

  $function->call( $function->global->upgrade(@args) )
  $function->(@args)

package JE::Object::Function;

our $VERSION = '0.044';


use strict;
use warnings; no warnings 'utf8';
use Carp                 ;
use Scalar::Util 'blessed';

use overload
	fallback => 1,
	'&{}' => sub {
		my $self = shift;
		sub {
			my $ret = $self->call($self->global->upgrade(@_));
			typeof $ret eq 'undefined' ? undef : $ret
		}
	 };

our @ISA = 'JE::Object';

require JE::Code         ;
require JE::Number          ;
require JE::Object              ;
require JE::Object::Error::TypeError;
require JE::Parser                    ;
require JE::Scope                      ;

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

sub new {
	# E 15.3.2
	my($class,$scope) = (shift,shift);
	my %opts;

	if(ref $scope eq 'HASH') {
		%opts = %$scope;
		$scope = $opts{scope};
	}
	else {
		%opts = @_ == 1  # bypass param-parsing for the sake of
		                 # efficiency
		? 	( function => shift )
		: 	( argnames => do {
				my $src = '(' . join(',', @_[0..$#_-1]) .
					')';
				$src =~ s/\p{Cf}//g;
				# ~~~ What should I do here for the file
				#     name and the starting line number?
				my $params = JE::Parser::_parse(
					params => $src, $scope
				);
				$@ and die $@;
				$params;
			  },
			  function => pop )
		;
	}

	defined blessed $scope
	    or croak "The 'scope' passed to JE::Object::Function->new (" .
		(defined $scope ? $scope : 'undef') . ") is not an object";

# ~~~ I should be able to remove the need for this to be a JE::Scope. Per-
#     haps it could be an array ref instead. That way, the caller won’t
#     have to bless something that we copy & bless further down anyway.
#     Right now, other parts of the code base rely on it, so it would
#     require a marathon debugging session.
	ref $scope ne 'JE::Scope' and $scope = bless [$scope], 'JE::Scope';
	my $global = $$scope[0];

	my $self = $class->SUPER::new($global, {
		prototype => $global->prototype_for('Function')
	});
	my $guts = $$self;

	$$guts{scope} = $scope;


	$opts{no_proto} or $self->prop({
		name     => 'prototype',
		dontdel  => 1,
		value    => JE::Object->new($scope),
	})->prop({
		name     => 'constructor',
		dontenum => 1,
		value    => $self,
	});

	{ no warnings 'uninitialized';

	$$guts{function} =
	  ref($opts{function}) =~ /^(?:JE::Code|CODE)\z/ ? $opts{function}
	: length $opts{function} &&
		(
		  parse $global $opts{function} or die
		)
	;

	$self->prop({
		name     => 'length',
		value    => JE::Number->new($global, $opts{length} ||
		            (ref $opts{argnames} eq 'ARRAY'
		                ? scalar @{$opts{argnames}} : 0)),
		dontenum => 1,
		dontdel  => 1, 
		readonly => 1,
	});

	} #warnings back on

	$$guts{func_argnames} = [
		ref $opts{argnames} eq 'ARRAY' ? @{$opts{argnames}} : ()
	];
	$$guts{func_args} = [
		ref $opts{function_args} eq 'ARRAY'
		? @{$opts{function_args}} :
		'args'
	];

	if(exists $opts{constructor}) {
		$$guts{constructor} = $opts{constructor};
		$$guts{constructor_args} = [
			ref $opts{constructor_args} eq 'ARRAY'
			? @{$opts{constructor_args}} : ('scope', 'args')
				# ~~~ what is the most useful default here?
		];
	}
	if(exists $opts{name}) {
		$$guts{func_name} = $opts{name};
	}

	$self->prop({dontdel=>1, name=>'arguments',value=>$global->null});
	 	
	$self;
}

sub call_with {
 my $func = shift;
 my $ret = $func->apply( $func->global->upgrade(@_) );
 typeof $ret eq 'undefined' ? undef : $ret
}

sub call {
	my $self = shift;
	$self->apply($$$self{global}, @_);
}

sub construct { # ~~~ we need to upgrade the args passed to construct, but 
                #     still retain the unupgraded values to pass to the 
                #     function *if* the function wants them downgraded
	my $self = shift;
	my $guts = $$self;
	if(exists $$guts{constructor}
	   and ref $$guts{constructor} eq 'CODE') {
		my $code = $$guts{constructor};
		my @args;
		for(  @{ $$guts{constructor_args} }  ) {
			push @args,
			  $_ eq 'self'
			?	$self
			: $_ eq 'scope'
			?	_init_scope($self, $$guts{scope},
					[], @_)
			: $_ eq 'args'
			?	@_ # ~~~ downgrade if wanted
			: $_ eq '[args]'
			?	[@_] # ~~~ downgrade if wanted
			: 	undef;
		}
		# ~~~ What can we do to avoid the upgrade overhead for
		#     JS internal functions?
		return $$guts{global}->upgrade($code->(@args));
	}
	else {
		# If the prototype property does not exist, then, since it
		# is undeletable, this can only be a function created with
		# no_proto => 1, i.e., an internal functions that’s meant
		# to die here.
		defined(my $proto = $self->prop('prototype'))
			or die JE::Object::Error::TypeError->new(
				$$guts{global}, add_line_number
				+($$guts{func_name} || 'The function').
				    " cannot be called as a constructor");

		my $obj = JE::Object->new($$guts{global},
			!$proto->primitive ?
				{ prototype => $proto }
			: ()
		);
		my $return = $$guts{global}->upgrade(
			$self->apply($obj, @_)
		);
		return $return->can('primitive') && !$return->primitive
			? $return
			: $obj;
	}
}

sub apply { # ~~~ we need to upgrade the args passed to apply, but still
            #     retain the unupgraded values to pass to the function *if*
            #     the function wants them downgraded
	my ($self, $obj) = (shift, shift);
	my $guts = $$self;
	my $global = $$guts{global};

	if(!blessed $obj or ref $obj eq 'JE::Object::Function::Call' 
	    or ref($obj) =~ /^JE::(?:Null|Undefined)\z/) {
		$obj = $global;
	}

	if(ref $$guts{function} eq 'CODE') {
		my @args;
		for(  @{ $$guts{func_args} }  ) {
			push @args,
			  $_ eq 'self'
			?	$self
			: $_ eq 'scope'
			?	_init_scope($self, $$guts{scope},
					$$guts{func_argnames}, @_)
			: $_ eq 'this'
			?	$obj
			: $_ eq 'args'
			?	@_ # ~~~ downgrade if wanted
			: $_ eq '[args]'
			?	[@_] # ~~~ downgrade if wanted
			: 	undef;
		}
		return $global->upgrade(
			# This list slice is necessary to work around a bug
			# in perl5.8.8 (but not in 5.8.6 or 5.10). Try
			# running this code to see what  I  mean:
			# 
			# bless ($foo=[]); sub bar{print "ok\n"}
			# $foo->bar(sub{warn;return "anything"}->())
			#
			(scalar $$guts{function}->(@args))[0]
		);
	}
	elsif ($$guts{function}) {
		my $at = $@;
		my $scope = _init_scope(
				$self, $$guts{scope},
				$$guts{func_argnames}, @_
			);
		my $time_bomb = bless [$self, $self->prop('arguments')],
			'JE::Object::Function::_arg_wiper';
		$self->prop('arguments', $$scope[-1]{-arguments});
		my $ret = $$guts{function}->execute(
			$obj->to_object, $scope, 2
		);
		defined $ret or die;
		$@ = $at;
		return $ret;
	}
	else {
		return $global->undefined;
	}
}

sub JE::Object::Function::_arg_wiper::DESTROY {
	$_[0][0] # function
	 ->prop(
	  'arguments', $_[0][1] # old arguments value
	 )
}

sub _init_scope { # initialise the new scope for the function call
	my($self, $scope, $argnames, @args) = @_;

	bless([ @$scope, JE::Object::Function::Call->new({
		global   => $scope,
		argnames => $argnames,
		args     => [@args],
		function => $self,
	})], 'JE::Scope');
}

sub typeof { 'function' }

sub class { 'Function' }

sub value { die "JE::Object::Function::value is not yet implemented." }


#----------- PRIVATE SUBROUTINES ---------------#

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

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

	# E 15.3.4
	$proto->prop({
		dontenum => 1,
		name => 'constructor',
		value => $scope->prop('Function'),
	});

	$proto->prop({
		name      => 'toString',
		value     => JE::Object::Function->new({
			scope    => $scope,
			name     => 'toString',
			no_proto => 1,
			function_args => ['this'],
			function => sub {
				my $self = shift;
				$self->isa(__PACKAGE__) or die new
					JE::Object::Error::TypeError
					$scope, add_line_number "Function."
					."prototype.toString can only be "
					."called on functions";
				my $guts = $$self;
				my $str = 'function ';
				JE::String->_new($scope,
				  'function ' .
				  ( exists $$guts{func_name} ?
				    $$guts{func_name} :
				    'anon'.$self->id) .
				  '(' .
				  join(',', @{$$guts{func_argnames}})
				  . ") {" .
				  ( ref $$guts{function}
				    eq 'JE::Code'
				    ? do {
				      my $code = 
				        $$guts{function};
				      my $offsets =
				        $$guts{function}
				          {tree}[0];
				      $code = substr ${$$code{source}},
				                     $$offsets[0],
				                     $$offsets[1] -
				                       $$offsets[0];
				      # We have to check for a final line
				      # break in case it ends with a sin-
				      # gle-line comment.
				      $code =~ /[\cm\cj\x{2028}\x{2029}]\z/
				      ? $code : $code . "\n"
				    }
				    : "\n    // [native code]\n"
				  ) . '}'
# ~~~ perhaps this should be changed so it doesn't comment out the
#     the [native code] thingy. That way an attempt to
#     eval the strung version will fail. (In this case, I need to add a
#     teest too make sure it dies.)
				);
			},
		}),
		dontenum  => 1,
	});
	$proto->prop({
		name      => 'apply',
		value     => JE::Object::Function->new({
			scope    => $scope,
			name     => 'apply',
			argnames => [qw/thisArg argArray/],
			no_proto => 1,
			function_args => ['this','args'],
			function => sub {
				my($self,$obj,$args) = @_;

				my $at = $@;

				no warnings 'uninitialized';
				if(defined $args and
				   ref($args) !~ /^JE::(Null|Undefined|
										Object::Function::Arguments)\z/x
				   and eval{$args->class} ne 'Array') {
					die JE::Object::Error::TypeError
					->new($scope, add_line_number
					      "Second argument to "
					      . "'apply' is of type '" . 
					      (eval{$args->class} ||
					       eval{$args->typeof} ||
					       ref $args) .
					      "', not 'Arguments' or " .
					      "'Array'");
				}
				$@ = $at;
				$args = $args->value if defined $args;
				$self->apply($obj, defined $args ?
					@$args : ());
			},
		}),
		dontenum  => 1,
	});
	$proto->prop({
		name      => 'call',
		value     => JE::Object::Function->new({
			scope    => $scope,
			name     => 'call',
			argnames => ['thisArg'],
			no_proto => 1,
			function_args => ['this','args'],
			function => sub {
				shift->apply(@_);
			},
		}),
		dontenum  => 1,
	});
}


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

package JE::Object::Function::Call;

our $VERSION = '0.044';

sub new {
	# See sub JE::Object::Function::_init_sub for the usage.

	my($class,$opts) = @_;
	my @args = @{$$opts{args}};
	my(%self,$arg_val);
	for(@{$$opts{argnames}}){
		$arg_val = shift @args;
		$self{-dontdel}{$_} = 1;
		$self{$_} = defined $arg_val ? $arg_val :
			$$opts{global}->undefined;
	}

	$self{-dontdel}{arguments} = 1;

	$self{'-global'}  = $$opts{global};
	# A call object's properties can never be accessed via bracket
	# syntax, so '-global' cannot conflict with properties, since the
	# latter have to be valid identifiers. Same 'pplies to dontdel, o'
	# course.
	
	# Note on arguments vs  -arguments:  ‘arguments’  represents the
	# actual ‘arguments’  property,  which may or may not refer to the
	# Arguments object,  depending on  whether  there  is  an  argument
	# named  ‘arguments’.  ‘-arguments’  always refers to the Arguments
	# object, which we need further up when we assign to the arguments
	# property of the function itself.

	$self{-arguments} = 
			JE::Object::Function::Arguments->new(
				$$opts{global},
				$$opts{function},
				\%self,
				$$opts{argnames},
				@{$$opts{args}},
			);
	unless (exists $self{arguments}) {
		$self{arguments} = $self{-arguments}
	};

	return bless \%self, $class;
}

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

	if(ref $name eq 'HASH') {
		my $opts = $name;
		$name = $$opts{name};
		@_ = exists($$opts{value}) ? $$opts{value} : ();
		$$self{'-dontdel'}{$name} = !!$$opts{dontdel}
			if exists $$opts{dontdel};
	}

	if (@_ ) {
		return $$self{$name} = shift;
	}

	if (exists $$self{$name}) {
		return $$self{$name};
	}

	return
}

sub delete {
	my ($self,$varname) = @_;
	unless($_[2]) { # if $_[2] is true we delete it anyway
		exists $$self{-dontdel}{$varname}
			&& $$self{-dontdel}{$varname}
			&& return !1;
	}
	delete $$self{-dontdel}{$varname};
	delete $$self{$varname};
	return 1;
}

sub exists { exists $_[0]{$_[1]} }
sub prototype{}




package JE::Object::Function::Arguments;

our $VERSION = '0.044';

our @ISA = 'JE::Object';

sub new {
	my($class,$global,$function,$call,$argnames,@args) = @_;
	
	my $self = $class->SUPER::new($global);
	my $guts = $$self;

	$$guts{args_call} = $call;
	$self->prop({
		name => 'callee',
		value => $function,
		dontenum => 1,
	});
	$self->prop({
		name => 'length',
		value => JE::Number->new($global, scalar @args),
		dontenum => 1,
	});
	$$guts{args_length} = @args; # in case the length prop
	                              # gets changed

	my (%seen,$name,$val);
	for (reverse 0..($#args,$#$argnames)[$#$argnames < $#args]) {
		($name,$val) = ($$argnames[$_], $args[$_]);
		if($seen{$name}++) {
			$self->prop({
				name => $_,
				value => $val,
				dontenum => 1,
			});
		}
		else {
			$$guts{args_magic}{$_} = $name;
		}
	}

	# deal with any extra properties
	for (@$argnames..$#args) {
		$self->prop({
			name => $_,
			value => $args[$_],
			dontenum => 1,
		});
	}

	$self;
}

sub prop {
	# Some properties are magically linked to properties of
	# the call object.

	my($self,$name) = @_;
	my $guts = $$self;
	if (exists $$guts{args_magic} and exists $$guts{args_magic}{$name})
	{
		return $$guts{args_call}->prop(
			$$guts{args_magic}{$name}, @_[2..$#_]
		);
	}
	SUPER::prop $self @_[1..$#_];
}

sub delete { 
	# Magical properties are still deleteable.
	my($self,$name) = @_;
	my $guts = $$self;
	if (exists $$guts{args_magic} and exists $$guts{args_magic}{$name})
	{
		delete $$guts{args_magic}{$name}
	}
	SUPER::delete $self @_[1..$#_];
}

sub value {
	my $self = shift;
	[ map $self->prop($_), 0..$$$self{args_length}-1 ];
}

1;