#!perl
package Foo;
use Test::More tests => 31;
use strict;
use JSPL qw(:flags);
sub new {
my $pkg = shift;
$pkg = ref $pkg || $pkg;
return bless {}, $pkg;
}
my $rt1 = JSPL::Runtime->new();
# Check constructor and package stuff
{
# If we don't define package assume same as name
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => sub {
my $pkg = shift;
is($pkg, "Foo", "package is Foo in Foo constructor");
return Foo->new();
}
);
my $o = $cx1->eval("new Foo();");
isa_ok($o, "Foo", "new Foo(); returns instanceof Foo");
$cx1->bind_class(name => "Bar",
constructor => sub {
my $pkg = shift;
is($pkg, "Foo", "package is Foo in Bar constructor");
return $pkg->new();
},
package => "Foo",
);
my $p = $cx1->eval("new Bar()");
isa_ok($p, "Foo", "new Bar() returns instanceof Foo");
}
{
# Default constructor
# If we don't define package assume same as name
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo");
$cx1->bind_class(name => "Baz", package => "Foo");
my $o = $cx1->eval("new Foo();");
isa_ok($o, "Foo", "new Foo() returns instanceof Foo");
$o = $cx1->eval("new Baz();");
isa_ok($o, "Foo", "new Baz() returns instanceof Foo");
}
# Check fs and static_fs
{
my $Foo_object_method = 0;
sub object_method {
my $self = shift;
isa_ok($self, "Foo", "self is Foo in object_method");
is($_[0], scalar @_, "1 arg in object_method");
$Foo_object_method++;
}
my $Foo_class_method = 0;
sub class_method {
my $self = shift;
is($self, "Foo", "self is Foo in class_method");
is($_[0], scalar @_, "1 arg in class_method");
$Foo_class_method++;
}
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => \&Foo::new,
fs => { object_method => \&Foo::object_method },
static_fs => { class_method => \&Foo::class_method, },
package => "Foo",
);
$cx1->eval("o = new Foo(); o.object_method(1)");
if ($@ || $Foo_object_method == 0) {
ok(0, "self is Foo in object_method");
ok(0, "1 arg in object_method");
}
$cx1->eval("Foo.class_method(1);");
if ($@ || $Foo_class_method == 0) {
ok(0, "self is Foo in class_method");
ok(0, "1 arg in class_method");
}
}
# Check multiple instance methods
{
sub fone {
is($_[1], 1, "called fone");
}
sub ftwo {
is($_[1], 2, "called ftwo");
}
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => "new",
fs => [qw(fone ftwo)],
);
$cx1->eval("o = new Foo(); o.fone(1); o.ftwo(2)");
if ($@) {
ok(0, "called fone");
ok(0, "called ftwo");
}
}
# Check ps
{
my $x = 5;
sub get_x {
my $self = shift;
isa_ok($self, "Foo", "self is Foo in get_x");
return $x;
}
sub set_x {
my $self = shift;
isa_ok($self, "Foo", "self is Foo in set_x");
$x = shift;
}
sub get_y {
my $self = shift;
isa_ok($self, "Foo", "self is Foo in get_y");
return 10;
}
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => \&Foo::new,
ps => { x => { getter => 'get_x',
setter => \&Foo::set_x,
},
y => [qw(get_y)],
},
);
my $r = $cx1->eval("a = new Foo(); f = a.x;");
is($r, 5);
$r = $cx1->eval("a = new Foo(); f = a.x; f++; a.x = f; f = a.x; a.x;");
is($r, 6);
}
# Check static_ps
{
my $z = 10;
sub get_z {
my $self = shift;
is($self, "Foo", "self is Foo in get_z");
return $z;
}
sub set_z {
my $self = shift;
is($self, "Foo", "self is Foo in set_z");
$z = shift;
}
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => \&Foo::new,
static_ps => { z => [qw(get_z set_z)],
},
);
my $r = $cx1->eval("Foo.z;");
diag($@) if $@;
is($r, 10, "Foo.z is 10");
$cx1->eval("Foo.z = 11;");
diag($@) if $@;
is($z, 11, "Foo.z is 11 after assignment");
}
{
# Check that static_ps and ps can coexist
my $cx1 = $rt1->create_context();
$cx1->bind_class(name => "Foo",
constructor => "new",
ps => { x => { getter => sub { return "x"; } } },
static_ps => { y => { getter => sub { return "y"; } } }
);
is($cx1->eval("(new Foo()).x"), "x", "(new Foo()).x return x");
diag($@) if $@;
is($cx1->eval("Foo.y"), "y", "Foo.y returns y");
diag($@) if $@;
}
{
# Check flags
my $cx1 = $rt1->create_context();
ok(JS_CLASS_NO_INSTANCE, "Flag defined");
$cx1->bind_class(name => "Baz",
package => "Foo",
flags => JS_CLASS_NO_INSTANCE
);
throws_ok {
$cx1->eval("new Baz()");
} qr/can't be instantiated/, "Try to instantiate and got exception";
my $foo = Foo->new();
isa_ok($foo, "Foo", "Perl can instantiate");
lives_ok { $cx1->bind_value("baz" => $foo) } "Bind value works";
isa_ok($cx1->eval("baz"), "Foo", "Imported a Baz into JS");
is($cx1->eval("baz + ''"), "[object Baz]", "In JS isa Baz");
}
# LocalWords: STDERR