package JE::Object::Function;
our $VERSION = '0.062';
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;
=head1 NAME
JE::Object::Function - JavaScript function class
=head1 SYNOPSIS
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);
=head1 DESCRIPTION
All JavaScript functions are instances of this class. If you want to call
a JavaScript function from Perl, just treat is as a coderef (C<< $f->() >>)
or use the C<call_with> method (C<< $f->call_with($obj, @args) >>) if you
want to specify the invocant (the 'this' value).
=head1 OBJECT CREATION
=over 4
=item new
Creates and returns a new function (see the next few items for its usage).
The new function will have a C<prototype> property that is an object with
a C<constructor> property that refers to the function itself.
The return value of the function will be upgraded if necessary (see
L<UPGRADING VALUES|JE::Types/UPGRADING VALUES> in the JE::Types man page),
which is why C<new> I<has> to be given a reference to the global object
or the scope chain. (But see also L<JE/new_function> and L<JE/new_method>.)
A function written in Perl can return an lvalue if it wants to. Use
S<< C<new JE::LValue($object, 'property name')> >> to create it. To create
an lvalue
that
refers to a variable visible within the function's scope, use
S<< C<<< $scope->var('varname') >>> >> (this assumes that you have
shifted the scope object off C<@_> and called it C<$scope>; you also need
to call C<new> with hashref syntax and specify the C<function_args> [see
below]).
=item new JE::Object::Function $scope_or_global, @argnames, $function;
=item new JE::Object::Function $scope_or_global, $function;
C<$scope_or_global> is one of the following:
- a global (JE) object
- a scope chain (JE::Scope) object
C<@argnames> is a list of argument names, that JavaScript functions use to access the arguments.
$function is one of
- a string containing the body of the function (JavaScript code)
- a JE::Code object
- a coderef
=item new JE::Object::Function { ... };
This is the big fancy way of creating a function that lets you do anything.
The elements of the hash ref passed to C<new> are as follows (they are
all optional, except for C<scope>):
=over 4
=item name
The name of the function. This is used only by C<toString>.
=item scope
A global object or scope chain object.
=item length
The number of arguments expected. If this is omitted, the number of
elements of C<argnames> will be used. If that is omitted, 0 will be used.
Note that this does not cause the argument list to be checked. It only
provides the C<length> property (and possibly, later, an C<arity> property)
for inquisitive scripts to look at.
=item argnames
An array ref containing the variable names that a JS function uses to
access the
arguments.
=item function
A coderef, string of JS code or JE::Code object (the body of the function).
This will be run when the function is called from JavaScript without the
C<new> keyword, or from Perl via the C<call> method.
=item function_args
This only applies when C<function> is a code ref. C<function_args> is an
array ref, the elements being strings that indicated what arguments should
be passed to the Perl subroutine. The strings, and what they mean, are
as follows:
self the function object itself
scope the scope chain
global the global object
this the invocant
args the arguments passed to the function (as individual
arguments)
[args] the arguments passed to the function (as an array ref)
If C<function_args> is omitted, 'args' will be assumed.
=item constructor
A code ref that creates and initialises a new object. This is called when
the C<new> keyword is used in JavaScript, or when the C<construct> method
is used in Perl.
If this is omitted, when C<new> or C<construct> is used, a new empty object
will be created and passed to the
sub specified under C<function> as its 'this' value. The return value of
the sub will be
returned I<if> it is an object; the (possibly modified) object originally
passed to the function will be returned otherwise.
=item constructor_args
Like C<function_args>, but the C<'this'> string does not apply. If
C<constructor_args> is
omitted, the arg list will be set to
C<[ qw( scope args ) ]> (B<this might change>).
This is completely ignored if C<constructor> is
omitted.
=item downgrade (not yet implemented)
This applies only when C<function> or C<constructor> is a code ref. This
is a boolean indicating whether the arguments to the function should have
their C<value> methods called automatically.; i.e., as though
S<<< C<< map $_->value, @args >> >>> were used instead of C<@args>.
=item no_proto
If this is set to true, the returned function will have no C<prototype>
property.
=back
=back
=head1 METHODS
=over 4
=item new JE::Object::Function
See L<OBJECT CREATION>.
=cut
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($global),
})->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;
}
=item call_with ( $obj, @args )
Calls a function with the given arguments. The C<$obj> becomes the
function's invocant. This method is intended for general use from the Perl
side. The arguments (including C<$obj>) are automatically upgraded.
=cut
sub call_with {
my $func = shift;
my $ret = $func->apply( $func->global->upgrade(@_) );
typeof $ret eq 'undefined' ? undef : $ret
}
=item call ( @args )
This method, intended mainly for internal use, calls a function with the
given arguments, without upgrading them. The invocant (the 'this' value)
will be the global object. This is just a wrapper around C<apply>.
This method is very badly named and will probably be renamed in a future
version. Does anyone have any suggestions?
=cut
sub call {
my $self = shift;
$self->apply($$$self{global}, @_);
}
=item construct
This method, likewise intended mainly for internal use, calls the
constructor, if this function has one (functions written in JS
don't have this). Otherwise, an object will be created and passed to the
function as its invocant. The return value of the function will be
discarded, and the object (possibly modified) will be returned instead.
=cut
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;
my $global = $$guts{global};
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 'global'
? $global
: $_ 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 $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(
$global, add_line_number
+($$guts{func_name} || 'The function').
" cannot be called as a constructor");
my $obj = JE::Object->new($global,
!$proto->primitive ?
{ prototype => $proto }
: ()
);
my $return = $global->upgrade(
$self->apply($obj, @_)
);
return $return->can('primitive') && !$return->primitive
? $return
: $obj;
}
}
=item apply ( $obj, @args )
This method, intended mainly for internal use just like the two above,
calls the function with $obj as the invocant and @args as the args. No
upgrading occurs.
This method is very badly named and will probably be renamed in a future
version. Does anyone have any suggestions?
=cut
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 'global'
? $global
: $_ 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 {
if (!defined $global) { use Carp; Carp::cluck() }
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 => $$$self{global},
argnames => $argnames,
args => [@args],
function => $self,
})], 'JE::Scope');
}
=item typeof
This returns the string 'function'.
=cut
sub typeof { 'function' }
=item class
This returns the string 'Function'.
=cut
sub class { 'Function' }
=item value
Not yet implemented.
=cut
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 ---------------#
=back
=head1 OVERLOADING
You can use a JE::Object::Function as a coderef. The sub returned simply
invokes the C<call> method, so the following are equivalent:
$function->call( $function->global->upgrade(@args) )
$function->(@args)
The stringification, numification, boolification, and hash dereference ops
are also overloaded. See L<JE::Object>, which this class inherits from.
=head1 SEE ALSO
=over 4
=item JE
=item JE::Object
=item JE::Types
=item JE::Scope
=item JE::LValue
=back
=cut
package JE::Object::Function::Call;
our $VERSION = '0.062';
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.062';
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
=begin pseudocode
Go through the named args one by one in reverse order, starting from $#args
if $#args < $#params
If an arg with the same name as the current one has been seen
Create a regular numbered property for that arg.
Else
Create a magical property.
=end pseudocode
=cut
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;