#!perl -T
BEGIN { require './t/test.pl' }
use Test::More tests => 100;
use Scalar::Util 'refaddr';
use strict;
use utf8;
#--------------------------------------------------------------------#
# Tests 1-2: See if the modules load
BEGIN { use_ok 'JE::Object::Boolean' }; # Make sure it loads without JE
# already loaded.
BEGIN { use_ok 'JE' };
#--------------------------------------------------------------------#
# Tests 3-6: Object creation
our $j = JE->new,;
isa_ok $j, 'JE', 'global object';
our $t = new JE::Object::Boolean $j ,1;
our $f = new JE::Object::Boolean $j, 0.;
our $n = new JE::Object::Boolean $j,;
isa_ok $t, 'JE::Object::Boolean', 'true';
isa_ok $f, 'JE::Object::Boolean', 'folse';
isa_ok $n, 'JE::Object::Boolean', 'default boolean';
#--------------------------------------------------------------------#
# Tests 7-27: prop
{
is $t->prop(thing => $j->upgrade('value')), 'value',
'prop returns the assigned value';
is $t->prop('thing'), 'value', 'the assignment worked';
# Hash ref arg:
is $t->prop({
name => 'notes',
value => $j->upgrade('abcdefg'),
}), 'abcdefg', 'prop({}) returns the assigned value';
is $t->prop({ name => 'notes' }), 'abcdefg',
'prop({}) returns the property\'s value';
is $t->prop({
name => 'notes',
dontenum => 1,
}), 'abcdefg', 'prop({dontenum}) returns the value';
unlike join('-', $t->keys), qr/\bnotes\b/,
'prop({dontenum}) works';
is $t->prop({
name => 'notes',
dontdel => 1,
}), 'abcdefg', 'prop({dontdel}) returns the value';
ok !$t->delete('notes'), 'prop({dontdel}) works';
is $t->prop({
name => 'notes',
readonly => 1,
}), 'abcdefg', 'prop({readonly}) returns the value';
$t->prop(notes => 'ne pa bou ga di ke zo ne');
is $t->{notes}, 'abcdefg', 'prop({readonly}) works';
$t->prop({name => 'notes', value=>$j->upgrade('do re mi fa sol')});
is $t->{notes}, 'do re mi fa sol',
'prop({value}) changes read-only properties';
# Autoload
$t->prop({
name => 'notes',
value => $j->upgrade('ne pa bou ga di'),
autoload => 'die',
});
is $t->prop('notes'), 'ne pa bou ga di',
'autoload is ignored when value is present';
$t->prop({
autoload => '$::autoloaded = 1; $global->null',
name => 'notes',
});
is $t->{notes}, 'null', 'result of autoload string';
ok $::autoloaded, 'side-effect of autoload string';
$::autoloaded = 0; () = $t->{notes}; # () suppresses void warnings
ok !$::autoloaded, 'string autoload happens once';
# This test caused a bus error, because &JE::Code::execute (which
# had a goto exiting an eval) is being called from a tie handler.
my $auto;
$t->prop({
autoload => sub { $auto = 1; $j->eval('"string"') },
name => 'notes',
});
is $t->{notes}, 'string', 'result of autoload sub';
ok $auto, 'side-effect of autoload sub';
$auto = 0; () = $t->{notes}; # () suppresses void warnings
ok !$auto, 'sub autoload happens once';
# Fetch/store handlers
$t->prop({
name => 'abc',
fetch => sub {
$_[0]->global->upgrade(scalar reverse $_[1])
},
store => sub {
$_[2] = '!' . $_[1];
},
value => $j->upgrade('olleH'),
});
is $t->{abc}, 'Hello', 'prop({}) with value and fetch together';
$t->{abc} = 'olleH';
is $t->{abc}, 'Hello!', 'fetch/store';
delete $t->{abc};
# This behaviour is subject to change:
$t->prop({
name => 'eval',
store => sub {
my $global = $_[0]->global;
my $code = $_[1];
$_[2] = sub {$global->upgrade(eval($code))};
},
});
$t->{eval} = '1+1';
is $t->{eval}, 2, 'store and implicit autoload';
delete $t->{eval};
}
#--------------------------------------------------------------------#
# Tests 28-9: keys
is_deeply [$t->keys], ['thing'], 'keys (1)';
is_deeply [$f->keys], [], 'keys (2)';
#--------------------------------------------------------------------#
# Test 30-2: delete
is_deeply $t->delete('anything'), 1, 'delete nonexistent property';
is_deeply $t->delete('thing'), 1, 'delete property';
is_deeply $t->delete('notes'), !1, 'delete undeletable property';
#--------------------------------------------------------------------#
# Tests 33-34: method
{
isa_ok my $ret = $t->method('toString'), 'JE::String',
'result of method("toString")';
ok $ret eq 'true',
'$t->method("toString") returns "true"';
}
#--------------------------------------------------------------------#
# Tests 35-7: value
is_deeply $t->value, 1, '$t->value';
is_deeply $f->value, !1, '$f->value';
is_deeply $n->value, !1, '$n->value';
#--------------------------------------------------------------------#
# Test 38: call
eval {
$t->call
};
like $@, qr/^Can't locate object method/, 'call dies';
#--------------------------------------------------------------------#
# Test 39: apply
eval {
$t->apply
};
like $@, qr/^Can't locate object method/, 'apply dies';
#--------------------------------------------------------------------#
# Test 40: construct
eval {
$t->construct
};
like $@, qr/^Can't locate object method/, 'construct dies';
#--------------------------------------------------------------------#
# Tests 41-4: exists
$t->prop(thing => $j->undefined);
is_deeply $t->exists('anything'), !1, 'exists(nonexistent property)';
is_deeply $t->exists('thing'), 1, 'exists(property)';
# exists in conjunction with fetch & store handlers (when the property's
# value does not [yet] exist in the internal property hash)
$t->prop({ name => 'jim', fetch => sub {} });
ok $t->exists('jim'), 'exists when there is only a fetch handler';
delete $t->{jim};
$t->prop({ name => 'jim', store => sub {} });
ok $t->exists('jim'), 'exists when there is only a store handler';
delete $t->{jim};
#--------------------------------------------------------------------#
# Tests 45-47: is_readonly
is_deeply $t-> is_readonly('anything'), !1,
'is_readonly(nonexistent property)';
is_deeply $t-> is_readonly('thing'), !1, 'is_readonly(property)';
is_deeply $t-> is_readonly('notes'), 1,
'is_readonly(read-only property)';
#--------------------------------------------------------------------#
# Tests 48-51: is_enum
is_deeply $t-> is_enum('anything'), !1,
'is_enum(nonexistent property)';
is_deeply $t-> is_enum('thing'), 1, 'is_enum(property)';
is_deeply $t-> is_enum('notes'), !1, 'is_enum(unenumerable property)';
#--------------------------------------------------------------------#
# Test 52: typeof
is_deeply typeof $t, 'object', 'typeof returns "object"';
#--------------------------------------------------------------------#
# Test 53: class
is_deeply $t->class, 'Boolean', 'class returns "Boolean"';
#--------------------------------------------------------------------#
# Test 54: id
is_deeply $t->id, refaddr $t, 'id';
#--------------------------------------------------------------------#
# Test 55: primitive
is_deeply $t->primitive, !1, 'primitive returns !1';
#--------------------------------------------------------------------#
# Tests 56-61: to_primitive
{
my $thing;
isa_ok $thing = $t->to_primitive, 'JE::Boolean',
'$t->to_primitive';
is $thing, 'true', '$t->to_primitive';
isa_ok $thing = $f->to_primitive, 'JE::Boolean',
'$f->to_primitive';
is $thing, 'false', '$f->to_primitive';
isa_ok $thing = $n->to_primitive, 'JE::Boolean',
'$n->to_primitive';
is $thing, 'false', '$n->to_primitive';
}
#--------------------------------------------------------------------#
# Tests 62: to_boolean
{
isa_ok my $thing = $f->to_boolean, 'JE::Boolean',
'result of to_boolean';
is $thing, 'true', 'to_boolean returns true';
}
#--------------------------------------------------------------------#
# Tests 63-8: to_string
{
my $thing;
isa_ok $thing = $t->to_string, 'JE::String',
'$t->to_string';
is $thing, 'true', '$t->to_string';
isa_ok $thing = $f->to_string, 'JE::String',
'$f->to_string';
is $thing, 'false', '$f->to_string';
isa_ok $thing = $n->to_string, 'JE::String',
'$n->to_string';
is $thing, 'false', '$n->to_string';
}
#--------------------------------------------------------------------#
# Test 69-74: to_number
{
my $thing;
isa_ok $thing = $t->to_number, 'JE::Number',
'$t->to_number';
is $thing, 1, '$t->to_number';
isa_ok $thing = $f->to_number, 'JE::Number',
'$f->to_number';
is $thing, 0, '$f->to_number';
isa_ok $thing = $n->to_number, 'JE::Number',
'$n->to_number';
is $thing, 0, '$n->to_number';
}
#--------------------------------------------------------------------#
# Test 75: to_object
cmp_ok refaddr $t-> to_object, '==', refaddr $t, 'to_object';
#--------------------------------------------------------------------#
# Test 76: global
is refaddr $j, refaddr global $t, '->global';
#--------------------------------------------------------------------#
# Tests 77-83: Overloading
# %{} is dealt with further down
is "$t", 'true', 'string overloading of true';
is "$f", 'false', 'string overloading of false';;
is "$n", 'false', 'string overloading of default boolean';;
is !$f, '', '!$f';
is 0+$t, 1, '0+$t';
is 0+$f, 0, '0+$f';
is 0+$n, 0, '0+$n';
#--------------------------------------------------------------------#
# Tests 84-98: Hash ties
our %h;
*h = \%$t;
$t->delete(0);
is $h{thing}, 'undefined', 'FETCH property';
is_deeply $h{auue}, undef, 'FETCH nonexistent property';
$h{aoeu} = 'htns';
is $t->prop('aoeu'), 'htns', 'STORE property';
is delete $h{aoeu}, 'htns', 'return value of DELETE (hash)';
is_deeply $t->prop('htns'), undef, 'DELETE works';
ok !exists $h{snth}, 'EXISTS(nonexistent prop)';
ok exists $h{thing}, 'EXISTS(prop)';
ok !exists $h{toString}, 'EXISTS(inherited prop)';
is join('-', keys %h), 'thing', 'keys %{}';
eval {
%h = ();
};
like $@, qr/^Can't locate object method/, '%$t = () dies';
$h{0}{1} = 3;
isa_ok $h{0}, 'JE::Object', '$h{0} (after {}{} autovivifcation)';
is $h{0}{1}, 3, '$h{0}{1} after {}{} autovivification';
delete $h{0};
$h{0}[1] = 3;
isa_ok $h{0}, 'JE::Object::Array', '$h{0} (after {}[] autovivifcation)';
is $h{0}[1], 3, '$h{0}[1] after {}[] autovivification';
delete $h{0};
$h{0} = \%@;
ok !tied(%@),
'explicit hash assignment is not confused with autovivification';
#--------------------------------------------------------------------#
# Tests 99-100: Freezing with ties present
SKIP: {
eval 'require Data::Dump::Streamer' or
skip 'Data::Dump::Streamer not present', 2;
import Data::Dump::Streamer;
ok exists $$$t{tie}, 'hash tie is present before freeze';
{
local $SIG{__WARN__} = sub{};
require IO::Handle; # DDS (2.03) loads this, but I don't
# know that it always will.
my $black_hole = 'IO::Handle'->new;
Dump($t)->To($black_hole)->Out;
}
ok !exists $$$t{tie}, 'hash tie\'s gone';
}