view release on metacpan or  search on metacpan

t/bind_class.t  view on Meta::CPAN

);

$j->bind_class(
	package => 'NumberOnly',
	constructor => sub { bless [], 'NumberOnly' },
	to_string => undef,
	to_number => sub { 12345 }
);

$j->bind_class(
	package => 'StringOnly',
	constructor => sub { bless [], 'StringOnly' },
	to_string => sub { 'Here you are' },
	to_number => undef
);

$j->bind_class(
	package => 'HintRequired',
	constructor => sub { bless [], 'HintRequired' },
	to_primitive => undef,
	to_string => sub { 'string' },
	to_number => sub { 'number' },
);

$j->bind_class(
	package => 'NotPrimitive',
	constructor => sub { bless [], 'NotPrimitive' },
	to_primitive => undef
);
$j->{diag} = \&diag unless $j->{diag};

defined $j->eval(<<'})() ') or die;

(function(){
	var t1 = new Heffelump
	var t2 = new Oliphaunt
	var t3 = new Elephant
	var t4 = new Gorilla
	var t5 = new NumberOnly
	var t6 = new StringOnly
	var t7 = new HintRequired
	var t8 = new NotPrimitive
	var error;

	is(String(t1), 'Look, we have a Heffelump')	
	is(   + t1, 678)
	is(String(t2), 'Look, we have an Oliphaunt')	
	is(   + t2, 678)
	is(String(t3), 'Look, we have an Elephant')	
	is(   + t3, 678)
	is('' + t4, 'no hint')	
	is(   + t4, 98765)
	is(String(t4), 'string')
	is(+t5, 12345)
	error=false;try{String(t5)}catch(e){error = true}ok(error)
	is(String(t6), 'Here you are')
	error=false;try{+ t6}catch(e){error = true}ok(error)
	is(String(t7), 'string')
//diag(t7)
//diag(+ (t7))
	is(     + t7 , NaN)
	error=false;try{'' + t7}catch(e){error = true}ok(error)
	error=false;try{'' + t8}catch(e){error = true}ok(error)
	error=false;try{+ t8}catch(e){error = true}ok(error)
	error=false;try{String(t8)}catch(e){error = true}ok(error)

})()
})() 


#--------------------------------------------------------------------#
# Tests 45-7: Class bindings: inheritance

$j->bind_class(
	package => 'HumptyDumpty',
	isa => 'String',
);

is refaddr $j->{String}{prototype},
   refaddr $j->upgrade(bless [], 'HumptyDumpty')->prototype->prototype,
   'isa => "String"';

$j->bind_class(
	package => 'JackHorner',
	isa => $j->{Array}{prototype},
);

is refaddr $j->{Array}{prototype},
   refaddr $j->upgrade(bless [], 'JackHorner')->prototype->prototype,
   'isa => $protoobject';

$j->bind_class( # Test 88 also relies on this binding, so make sure it
                # gets another if this is deleted.
	package => 'RunningOutOfWeirdIdeas',
	isa => undef
);

is_deeply $j->upgrade(bless [], 'RunningOutOfWeirdIdeas')->prototype
	->prototype, undef, 'isa => undef';

#--------------------------------------------------------------------#
# Test 48: Class bindings: proxy caching

{
	my $thing = bless [], 'RunningOutOfWeirdIdeas';
	is refaddr $j->upgrade($thing), refaddr $j->upgrade($thing),
		'proxy caching';
} 


#--------------------------------------------------------------------#
# Tests 49-88: Class bindings: properties

$j->{is} ||= \&is;
$j->{ok} ||= \&ok;

{
	package PropsArray;  # tests 'props => \@array'
	sub knew { bless [] }
	my($thing1,$thing2,$thing3,$thing4);
	sub prop1 { ++$thing1 . ' $a_' . ref($_[0]) . '->prop1' }

t/bind_class.t  view on Meta::CPAN

	array 2
	hash 2.5
) ;

{
	use Symbol;
	bless my $g = gensym, 'Arrash';
	${*$g}{length} = 17;
	${*$g}{0} = '4 jolly nerds';
	${*$g}{doodad} = '3 henchmen';

	my $ugh = $j->upgrade($g);

	is $ugh->{0}, '4 jolly nerds';
	is $ugh->{length}, 0;
	$ugh->{length} = 17;
	is @{*$g}, 17;
	is $ugh->{doodad}, '3 henchmen';

	delete ${*$g}{0};
	delete ${*$g}{doodad};

	is $ugh->{0}, 'undefined';
	$ugh->{length} = 0;
	is $ugh->{0}, 'something';
	is $ugh->{doodad}, 'weird';

	is join(':-)', sort keys %$ugh), '0:-)doodad:-)length';
}

# Bug in JE 0.036 and earlier: array- and hash-like classes do not over-
# ride exists to reflect the extra properties:
{
 my $a = $j->upgrade(bless \my %a, 'Hush!');
 $a{frext} = "ghed";
 ok $a->exists('frext'), 'exists works on hash elements';
 ok exists $$a{frext}, 'exists works on hash elements (tie interface)';
}


delete $j->{Object}{$_} for qw _0 doodad_;

#--------------------------------------------------------------------#
# Tests 126-69 (17+17+9+1=44): Class bindings: method return types

sub ___::AUTOLOAD{scalar reverse $___::AUTOLOAD}
sub ___::oof{}
sub ___::ooph{}

$j->bind_class(
	name => '___',
	methods => [qw[ foo:Number ___::bar ___::baz:null oof:null ]],
	static_methods =>[qw[FOO:Number ___::BAR ___::BAZ:null oof:null]],
	to_primitive => 'prim:Boolean',
	props => [qw[phoo:Number ___::barr ___::bazz:null ooph:null ]],
	static_props=>[qw[PHOO:Number ___::BARR ___::BAZZ:null ooph:null]],
);

{ # 17 tests here:
	my $foo = $j->upgrade(bless[],'___');
	is $foo->method('foo'), 'NaN', 'methods => [method:func]';
	is $foo->method('___::bar'), 'rab::___',
		'methods => [Package::method]';
	is $foo->method('___::baz'), 'zab::___',
		'methods => [Package::method:thing]';
	is $foo->method('oof'), 'null', 'methods => [method:null]';

	my $con#structor
		= $j->{___};
	is $con->method('FOO'), 'NaN', 'static_methods => [method:func]';
	is $con->method('___::BAR'), 'RAB::___',
		'static_methods => [Package::method]';
	is $con->method('___::BAZ'), 'ZAB::___',
		'static_methods => [Package::method:thing]';
	is $con->method('oof'), 'null', 'static_methods => [method:null]';

	is $foo->to_primitive, 'true', 'to_primtive => method:func';

	is $foo->{phoo}, 'NaN', 'props => [method:func]';
	is $foo->{'___::barr'}, 'rrab::___',
		'props => [Package::method]';
	is $foo->{'___::bazz'}, 'zzab::___',
		'props => [Package::method:thing]';
	is $foo->{ooph}, 'null', 'props => [method:null]';

	is $con->{PHOO}, 'NaN', 'static_props => [method:func]';
	is $con->{'___::BARR'}, 'RRAB::___',
		'static_props => [Package::method]';
	is $con->{'___::BAZZ'}, 'ZZAB::___',
		'static_props => [Package::method:thing]';
	is $con->{ooph}, 'null', 'static_props => [method:null]';

}

sub __::AUTOLOAD{scalar reverse $__'AUTOLOAD}
sub __::oof{}

$j->bind_class(
	name => '__',
	methods => {qw{
		phew foo:Number
		bare __::bar
		bass __::baz:null
		poof oof:null
	}},
	static_methods => {qw{
		PHEW foo:Number
		BARE __::BAR
		BASS __::BAZ:null
		POOF oof:null
	}},
	to_primitive => '__::prim:null',
	props => {qw{
		hati foo:Number
		uraa __::barr
		orut __::bazz:null
		hwha oof:null
	}},
	static_props => {qw{
		AHTI foo:Number
		URAI __::BARR
		ORUT __::BAZZ:null
		WHAT oof:null
	}},
);

{ # 17 tests here:
	my $foo = $j->upgrade(bless[],'__');
	is $foo->method('phew'), 'NaN',
		'methods => {name => method:func}';
	is $foo->method('bare'), 'rab::__',
		'methods => {name => Package::method}';
	is $foo->method('bass'), 'zab::__',
		'methods => {name => Package::method:thing}';
	is $foo->method('poof'), 'null',
		'methods => {name => method:null}';

	my $con#structor
		= $j->{__};
	is $con->method('PHEW'), 'NaN',
		'static_methods => {name => method:func}';
	is $con->method('BARE'), 'RAB::__',
		'static_methods => {name => Package::method}';
	is $con->method('BASS'), 'ZAB::__',
		'static_methods => {name => Package::method:thing}';
	is $con->method('POOF'), 'null',
		'static_methods => {name => method:null}';

	is $foo->to_primitive, 'mirp::__',
		'to_primtive => Pack::method:null';

	is $foo->{hati}, 'NaN', 'props => {name => method:func}';
	is $foo->{'uraa'}, 'rrab::__',
		'props => {name => Package::method}';
	is $foo->{'orut'}, 'zzab::__',
		'props => {name => Package::method:thing}';
	is $foo->{hwha}, 'null', 'props => {mname => ethod:null}';

	is $con->{AHTI}, 'NaN', 'static_props => {name => method:func}';
	is $con->{'URAI'}, 'RRAB::__',
		'static_props => {name => Package::method}';
	is $con->{'ORUT'}, 'ZZAB::__',
		'static_props => {name => Package::method:thing}';
	is $con->{WHAT}, 'null', 'static_props => {name => method:null}';

}

sub _::AUTOLOAD{scalar reverse $_'AUTOLOAD}
sub _::oof{}

$j->bind_class(
	name => '_',
	to_primitive => '_::prim',
	props => {
		hati => { fetch => 'foo:Number' },
		uraa => { fetch => '_::bar'     },
		orut => { fetch => '_::baz:null'},
		hwha => { fetch => 'oof:null'   },
	},
	static_props => {
		AHTI => { fetch => 'foo:Number' },
		URAI => { fetch => '_::BAR'     },
		ORUT => { fetch => '_::BAZ:null'},
		WHAT => { fetch => 'oof:null'   },
	},
);

{ # 9 tests here:
	my $foo = $j->upgrade(bless[],'_');

	is $foo->to_primitive, 'mirp::_',
		'to_primtive => Pack::method:null';

	is $foo->{hati}, 'NaN',
		'props => {name => {fetch => method:func}}';
	is $foo->{'uraa'}, 'rab::_',
		'props => {name => {fetch => Package::method}}';
	is $foo->{'orut'}, 'zab::_',
		'props => {name => {fetch => Package::method:thing}}';
	is $foo->{hwha}, 'null',
		'props => {mname => {fetch => ethod:null}}';

	my $con#structor
		= $j->{_};
	is $con->{AHTI}, 'NaN',
		'static_props => {name => {fetch => method:func}}';
	is $con->{'URAI'}, 'RAB::_',
		'static_props => {name => {fetch => Package::method}}';
	is $con->{'ORUT'}, 'ZAB::_',
		'static_props => {name => {fetch => Pack::method:thing}}';
	is $con->{WHAT}, 'null',
		'static_props => {name => {fetch => method:null}}';

}


sub ____::oof{}

$j->bind_class(
	name => '____',
	to_primitive => 'oof:null',
);

# 1 test here:
is $j->upgrade(bless[],'____')->to_primitive, 'null',
	'to_primitive => method:null';


#--------------------------------------------------------------------#
# Test 170: Class bindings: inherited property [gs]etters

$j->bind_class(package => 'base_class',
               props => { property => sub { ${+shift} } });
$j->bind_class(package => 'subclarce', isa => 'base_class');

{
	bless my $x = \(my $y = 'fo'), 'subclarce';
	is $j->upgrade($x)->{property}, 'fo',
		'inhertied property [gs]etters';
}

#--------------------------------------------------------------------#
# Tests 171-6: Class bindings: respect of Perl's overloading

{package ov; use overload '""' => sub { 43 }}
$j->bind_class(name => 'ov');
$j->bind_class(name => 'un');
is ($j->upgrade(bless [], 'ov')->to_string, 43,
	'Perl\'s string overloading in JS');
is ($j->upgrade(bless [], 'ov')->to_number, 43,
	'Perl\'s number overloading in JS');
is ($j->upgrade(bless [], 'ov')->to_primitive, 43,
	'Perl\'s overloading in JS');
is ($j->upgrade(bless [], 'un')->to_string, '[object un]',
	'Perl\'s stringification ignored without overloading');
is ($j->upgrade(bless [], 'un')->to_number, 'NaN',
	'Perl\'s numbification ignored without overloading');
is ($j->upgrade(bless [], 'un')->to_primitive, '[object un]',
	'Perl\'s stringification ignored without overloading (2)');


#--------------------------------------------------------------------#
# Tests 177-98: Scalar context for methods/coderefs passed to bind_class

sub scalartest::ten { 3, 10 }
sub scalartest::three { 7, 3 }
sub scalartest::twelve { 11, 12 }

$j->bind_class(
	package => 'scalartest',
	constructor => sub { (9, 10) },
	methods => ['twelve:Number'],
	static_methods => ['twelve:Number'],
	props => ['ten:Number', 'three'],
	static_props => ['ten:Number', 'three'],
);
is $j->eval('new scalartest'), 10,
	'scalar context for coderef constructor';
is $j->upgrade(bless[], 'scalartest')->method('twelve'), 12,
	'scalar context for typed method specified in array';
is $j->{scalartest}->method('twelve'), 12,
	'scalar context for typed static method specified in array';
is $j->upgrade(bless[], 'scalartest')->prop('ten'), 10,
	'scalar context for typed method-name prop specified in array';
is $j->upgrade(bless[], 'scalartest')->prop('three'), 3,
	'scalar context for untyped method-name prop specified in array';
is $j->{scalartest}->{ten}, 10,
    'scalar context for typed static method-name prop specified in array';
is $j->{scalartest}->{three}, 3,
  'scalar context for untyped static method-name prop specified in array';

$j->bind_class(
	package => 'scalartest',
	constructor => 'twelve',
	methods => { method => 'twelve:Number' },
	static_methods => { method => 'twelve:Number' },
	props => {
		prop => { fetch => sub { 2, 3 } },
		prop2 => { fetch => 'ten:Number' },
		prop3 => { fetch => 'ten' },
		prop4 => sub { 3, 4 },
		prop5 => 'ten:Number',
		prop6 => 'ten',
	},
	static_props => {
		prop => { fetch => sub { 2, 3 } },
		prop2 => { fetch => 'ten:Number' },
		prop3 => { fetch => 'ten' },
		prop4 => sub { 3, 4 },
		prop5 => 'ten:Number',
		prop6 => 'ten',
	},
);
is $j->eval('new scalartest'), 12,
	'scalar context for method constructor';
is $j->upgrade(bless[], 'scalartest')->method('method'), 12,