package JE::Object::Function; our $VERSION = '0.035'; use strict; use warnings; no warnings 'utf8'; use Carp ; use Scalar::Util 'blessed'; use overload fallback => 1, '&{}' => sub { my $self = shift; sub { $self->call($self->global->upgrade(@_)) } }; 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->call(@args); $f->construct(@args); # if this is a constructor function $f->apply($obj, @args); =head1 DESCRIPTION All JavaScript functions are instances of this class. =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 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($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; } =item call ( @args ) Calls a function with the given arguments. The invocant (the 'this' value) will be the global object. This is just a wrapper around C<apply>. =cut sub call { my $self = shift; $self->apply($$$self{global}, @_); } =item construct 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; 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; } } =item apply ( $obj, @args ) Calls the function with $obj as the invocant and @args as the args. =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 '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'); } =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 =cut package JE::Object::Function::Call; our $VERSION = '0.035'; 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.035'; 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;