File Coverage

blib/lib/WWW/Scripter/Plugin/JavaScript/SpiderMonkey.pm

Criterion	Covered	Total	%
statement	17	19	89.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	24	26	92.3

BEGIN { require 5.006 }

package WWW::Scripter::Plugin::JavaScript::SpiderMonkey;

use#
strict; use#
warnings;

use Carp 'croak';
use Hash::Util::FieldHash::Compat 'fieldhash';
use HTML::DOM::Interface ':all'; # for the constants
use JavaScript 1.12; # PerlSub type
use Scalar::Util qw'weaken blessed ';
use WWW'Scripter'Plugin'JavaScript 0.005; # back_end

our $VERSION = '0.003';

no constant 1.03 ();
use constant::lexical {
	wndw => 0,
	cntx => 1,
	setr => 2,
	exst => 3,
	hash => 4, # whether a particular package needs a hash wrapper
	isam => 5,
	wrap => 6, # hash wrappers
	defs => 7,
	defg => 8,
	defm => 9,
	getr =>10,
};

my $rt;

fieldhash my %destructibles;

sub new {
	$rt ||= new JavaScript::Runtime;

	my $class = shift;
	my $self = bless[], $class;
	$self->[wndw] = my $parathi = shift,
	$self->[cntx] = my $cx = $rt->create_context;
	$self->[hash] = {};

	# Weaken the reference to the WWW::Scripter object. Otherwise we
	# have a reference loop:
	#    	window -> js plugin -> sm back end -> window
	weaken $parathi;

	# cache $self so we can purge it in an END block
	weaken(my $weak_self = $self);
	$destructibles{$self} = \$weak_self;

	my @wrappers;
	@wrappers[BOOL,STR,OBJ] = @{ $cx->eval(' 0,function() {
		// for speed:
		frames = self = window = this
		return [
			function(func_name) {
		       		var f = this[func_name]
				func_name = function() {
					return Boolean(
						f.apply(this, arguments)
					)
				}
			},
			function(func_name) {
				var f = this[func_name]
				func_name = function() {
					var r = f.apply(this, arguments)
					return r === null || r === void 0
						? null : Object(r)
				}
			},
			function(func_name) {
				var f = this[func_name]
				func_name = function() {
					var r = f.apply(this, arguments)
					return r === null || r === void 0
						? null : ""+r
				}
			},
		]
	}() ') };


	my $i = \%WWW'Scripter'WindowInterface;
	my %methods;
	@methods{ grep !/^_/ && $$i{$_} & METHOD, =>=> keys %$i } = ();
	for(keys %methods) {
		my $method = $_;
		my $type = $$i{$_}&TYPE;
		if($type == NUM) {
			$cx->bind_function($_ => sub {
				0+$parathi->$method(@_);
			});
		}
		else {
			$cx->bind_function($_ => sub {
				$parathi->$method(@_);
			});
			$wrappers[$type]($_);
		}

	}

	my $fetch = $cx->eval('
	  0,function(p,f){__defineGetter__(p, function(){return f()})}
	');
	my $store = $cx->eval('
	  0,function(p,f){__defineSetter__(p, function(v){f(v)})}
	');
	weaken(my $cself = $self); # for closures (not foreclosures)
# ~~~ We still need to deal with type conversion.
	my %props;
	@props{ grep !/^_/ && !($$i{$_}&METHOD) =>=> keys %$i } = ();
	for(keys %props) {
		my $name = $_;
		next if $name =~ /^(?:frames|window|self)\z/; # for
		my $type = $$i{$_}&TYPE;                      # efficiency
		&$store($_ => sub {
				#my $self = shift;
				#$self->_cast(
				#	scalar
					  $self->[wndw]->$name,
				#	$types[$type&TYPE]
				#);
			});
		unless($type & READONLY) {
			&$fetch( $_ => sub {
					#my $self = shift;
					#$self->_cast(
					#	scalar
					my $ret = $cself->[wndw]->$name;
					exists $cself->[hash]{ref $ret}
					? $cself->hash_wrapper($ret)
					: $ret;
					#	$types[$type&TYPE]
					#);
				} );
		}
	}

	$self
}

END { # Empty any $selves *before*  global destruction,  to ensure that any
 for(values %destructibles) {  # SM objects we reference go away before the
  # This line causes a crash in perl 5.8.8. It seems   # runtime is  freed.
  # that 5.8.8 has some bug in av_clear in that it can end
  # up trying to write to the xpvav  struct after the array has
  # been freed.  Since, when the array is freed, the sv_any pointer
  # (which usually  points to the xpvav struct) points to another freed
  # sv, it causes a crash if that sv is used again. Or something like that.
  # I never did finish getting to the bottom of it.
  #@$$_ = ();
  undef $_ for @$$_;
 }
}

sub eval {
	my ($self,$code,$url,$line) = @_;
	defined $line and substr $code, 0, 0 =>= "\n" x ($line-1);
	$self->[cntx]->eval($code,$url)
}

sub set {
	croak "Not enough arguments for W:M:P:JS:SM->set" unless @_ > 2;

	my $self = shift;
	my @args = @_;
	if(my $h = $self->[hash]) {
		for(@args){
		 defined blessed $_ or next;
		 exists $$h{ref $_} and $_ = $self->hash_wrapper($_),
		}
	}
	( $$self[setr] ||= $self->[cntx]->eval('0,function() {
		var a = arguments;
		var $obj = this;
		var $val = a[a.length-1];
		var $prop = a[a.length-2];
		for (var i = 0; i < a.length-2; ++i) {
			var $_ = a[i]
			$_ in $obj || ($obj[$_] = {});
			$obj = $obj[$_];
		}
		$obj[$prop] = $val;
	  }') )
	  ->(@args);
	return;
}

sub bind_classes {
# ~~~ We still need to deal with type conversion and read-only props.
	my($self, $classes) = @_;
	weaken(my $cself = $self); # self for closures
	my $cx = $self->[cntx];
	my $exists = $self->[exst] ||= $cx->eval('0,function(prop) {
		return prop in this
	}');
	my @defer;
	my $isa_maker = $self->[isam] ||= $cx->eval('
		0,function(class,super) {
			this[class].__proto__ = this[super]
		}
	');
	my $define_setter = $self->[defs] ||= $cx->eval('
		0,function(class,prop,sub) {
			this[class].prototype.__defineSetter__(
			 prop,
			 function(v) {
			  sub(this, v)
			 }
			)
		}
	');
	my $define_string_getter = $self->[defg] ||= $cx->eval('
		0,function(class,prop,sub) {
			this[class].prototype.__defineGetter__(
			 prop,
			 function() {
			  var ret = sub(this)
			  return(
			   typeof ret == "undefined" ? null : String(ret)
			  );
			 }
			)
		}
	');
	my $define_string_meth = $self->[defm] ||= $cx->eval('
		0,function(class,prop,sub) {
			this[class].prototype[prop] = function() {
			  var ret = sub.apply(this,arguments);
			  return(
			   typeof ret == "undefined" ? null : String(ret)
			  );
			}
		}
	');


	for (grep /::/, keys %$classes) {
		my $i = $$classes{$$classes{$_}}; # interface info
		if($$i{_hash} || $$i{_array}) { #  **Shudder!**
		 my %props;
		 my %methods;
		 {
		  my $i = $i;
		  while() {
		   $props{$_} = undef
		    for grep !/^_/ && !($$i{$_} & METHOD),keys %$i;
		   $methods{$_} = undef
		    for grep !/^_/ && $$i{$_} & METHOD, keys %$i;
		   exists $$i{_isa} || last;
		   $i = $$classes{$$i{_isa}};
		  }
		 }
		 $self->[hash]{$_} = [
		  @$i{'_array','_hash'},\%props,\%methods
		 ];
		}
		else {
		 my @props = grep !/^_/ && !($$i{$_} & METHOD), keys %$i;
		 my @str_props;
		 my @str_meths;
		 $cx->bind_class(
		  package => $_,
		  name    => $$classes{$_},
		  methods => { map {
		   if(($$i{$_} & TYPE) == STR) {
		    push @str_meths, $_;
		    ()
		   }
		   else {
		    my $method = $_;
		    $_ => sub {
		     my $self = shift;
		     my $ret = $self->$method(@_);
		     exists $cself->[hash]{ref $ret}
		     ? $cself->hash_wrapper($ret)
		     : $ret
		    }
		   }
		  } grep !/^_/ && $$i{$_} & METHOD, keys %$i },
		  properties => { map {
		   if(($$i{$_} & TYPE) == STR) {
		    push @str_props, $_;
		    ()
		   }
		   else {
		    my $prop = $_;
		    $_ => [
		     sub {
		      my $self = shift;
		      my $ret = $self->$prop;
		      exists $cself->[hash]{ref $ret}
		      ? $cself->hash_wrapper($ret)
		      : $ret
		     },
		     sub {
		     # my $self = shift;
		     # my $ret = $self->$prop(@_);
		     # return;
		     },
		    ]
		   }
		  } @props },
		  exists $$i{_constructor}
		   ? (constructor => $$i{_constructor})
		   : (flags => JS_CLASS_NO_INSTANCE),
		 );
		 for my $p(@props) {
		  &$define_setter($$classes{$_}, $p, sub {
		   shift->$p(@_); return
		  });
		 }
		 for my $p(@str_props) {
		  &$define_string_getter($$classes{$_}, $p, sub {
		   shift->$p(@_);
		  });
		 }
		 for my $p(@str_meths) {
		  &$define_string_meth($$classes{$_}, $p, sub {
		   shift->$p(@_);
		  });
		 }
		}

		if(exists $$i{_constants}){
		   my $p = $_;
		   for(@{$$i{_constants}}){
		    /([^:]+\z)/;
		    $self->set($$classes{$p}, $1, eval);
		   }
		}

		if (exists $$i{_isa}) {
			if(!&$exists($$i{_isa})) {
				push @defer, [$$classes{$_}, $$i{_isa}]
			} else {
				$isa_maker->($$classes{$_}, $$i{_isa});
			}
		}
	}
	while(@defer) {
		my @copy = @defer;
		@defer = ();
		for (@copy) {
			if(&$exists($$_[1])) { # $$_[1] == superclass
				$isa_maker->(@$_);
			}
			else {
				push @defer, $_;
			}
		}
	}

	return;
}

sub event2sub {
	my ($self, $code, $elem, $url, $line) = @_;

	# We create a function with a specific scope chain by generating
	# and calling code like this:
	#  (function() {
	#   with(arguments[0])with(arguments[1])with(arguments[2])
	#    return function() { ... }
	#  })

	# The global object is automatically in the scope, so we don’t need
	# to add it explicitly.
	my @scope = (
		$elem->can('form') ? $elem->form : (),
		$elem
	);

	# We need the line break after $code, because there may be a sin-
	# gle-line comment at the end,  and no  line  break.  ("foo //bar"
	# would fail without this,  because the closing }})  would be  com-
	# mented out too.)
	($self->[cntx]->eval(
	  "\n" x($line-1) . "(function(){"
	  . (join '', map "with(arguments[$_])", 0..$#scope)
	  . "return function() { $code\n } })",
	  $url
	)||return) -> ( @scope );
}

sub new_function {
	my($self, $name, $sub) = @_;
	$self->set($name,$sub);
	return;
}

sub hash_wrapper {
	my $self = shift;
	my $w = $self->[wrap] ||= &fieldhash({});
	my $obj = shift;
	$w->{$obj} ||= do {
		my $wrapper = new JavaScript::PerlHash;
		# WWW::Scripter is the special case
		if(ref $obj eq 'WWW::Scripter') {
			tie
			  %{get_ref $wrapper},
			 __PACKAGE__.'::WindowProxy',
			  $obj;
		}
		else {
			my $binding_info = $self->[hash]{ref $obj};
			tie
			  %{$wrapper->get_ref},
			 __PACKAGE__.'::Hash',
			  $obj, @$binding_info, $self;
		}
		$wrapper;
	}
}

sub _hash_classes { shift->[hash] }


package WWW::Scripter::Plugin::JavaScript::SpiderMonkey::WindowProxy;
# Is this package name long enough?

sub TIEHASH {
	# Slot 0 is the WWW::Scripter object. Slot 1 is used to catch the
	# fetching function.
	bless [pop], shift;
}

sub STORE {
 my $w = ${;shift}[0];
 $w->plugin("JavaScript")->back_end($w)->set(shift, shift);
}

sub CLEAR{}

sub FETCH {
 my $self = shift;
 my $w = $$self[0];
 (
  $$self[1]
   ||= $w->plugin("JavaScript")->back_end($w)->eval(
        '0,function(k){ return this[k] }'
       )
 )->(shift)
}


package WWW::Scripter::Plugin::JavaScript::SpiderMonkey::Hash;

use constant::lexical {
 obje => 0, arry => 1, hash => 2, prop => 3, meth => 4, jsbe => 5,
};

sub TIEHASH {
	# args: 0) object to wrap
	#       1) array?
	#       2) hash?
	#       3) { props }
	#       4) { methods }
	#       5) JavaScript back end (wspjssm object)
	my $ret = bless \@_, shift;
#	warn "wrapping up a " . ref($obj) . " object with props [ @{$ret->[prop]} ]";
	Scalar::Util'weaken($ret->[jsbe]);
	$ret;
}

sub STORE {
 my $self = shift;
 my $name = shift;
 exists $self->[prop]{$name} and $self->[obje]->$name(shift), return;
 exists $self->[meth]{$name} and return;
 $self->[arry] && $name =~ /^(?:0|[1-9]\d*)\z/ && $name < 4294967295
 ? $self->[obje][$name]=shift
 :($self->[obje]{$name}=shift);
}

sub CLEAR{}

sub FETCH {
 my $self = shift;
 my $name = shift;
 my $ret =
  exists $self->[prop]{$name} ? $self->[obje]->$name :
  exists $self->[meth]{$name} ? return sub { $self->[obje]->$name(@_) } :
  $self->[arry] && $name =~ /^(?:0|[1-9]\d*)\z/ && $name < 4294967295
  ? $self->[obje][$name]
  : $self->[obje]{$name};
 exists $self->[jsbe]->_hash_classes->{ref $ret}
  ? $self->[jsbe]->hash_wrapper($ret)
  : $ret;
}


exit exit exit exit exit exit exit exit exit exit exit exit exit return 1;

# ------------------ DOCS --------------------#



=head1 NAME

WWW::Scripter::Plugin::JavaScript::SpiderMonkey - SpiderMonkey backend for wspjs

=head1 VERSION

0.003 (alpha)

=head1 SYNOPSIS

  use WWW::Scripter;

  my $w = new WWW::Scripter;
  $w->use_plugin('JavaScript', engine => 'SpiderMonkey');

  $w->get("http://...");
  # etc.

=head1 DESCRIPTION

This little module is a bit of duct tape to connect the JavaScript plugin
for L to the SpiderMonkey JavaScript engine via
L. Don't use this module
directly. For usage, see
L.

=head1 BUGS

There are too many to list! This thing is currently very unstable, to put
it mildly.

If you find any bugs, please report them via L
or
L (long e-mail
address, isn't it?).

=head1 SINE QUIBUS NON

perl 5.8.3 or higher (5.8.6 or higher recommended)

HTML::DOM 0.008 or later

JavaScript.pm 1.12 or later

Hash::Util::FieldHash::Compat

constant::lexical

=head1 AUTHOR & COPYRIGHT

Copyright (C) 2010-11, Father Chrysostomos (org.cpan@sprout backwards)

This program is free software; you may redistribute it, modify it or
both under the same terms as perl.

=head1 SEE ALSO

=over 4

=item -

L

=item -

L