use Test::More 'no_plan';
use strict;
use warnings;
use lib 't/object-simple';
BEGIN {
$SIG{__WARN__} = sub {
my $message = shift;
unless ($message =~ /DEPRECATED/ && $message =~ /Object::Simple/) {
warn $message;
}
};
}
# -base flag
{
{
use Some::T2;
my $o = Some::T2->new;
is($o->x, 1);
is($o->y, 2);
}
{
use T3;
my $o = T3->new;
is($o->x, 1);
is($o->y, 2);
is($o->z, 3);
}
{
package T4;
use Object::Simple -base => 'T3';
}
{
my $o = T4->new;
is($o->x, 1);
is($o->y, 2);
is($o->z, 3);
}
{
package T4_2;
use Object::Simple -base => 'T3_2';
}
{
my $o = T4_2->new;
is($o->x, 1);
is($o->y, 2);
is($o->z, 3);
}
}
# Test name
my $test;
sub test {$test = shift}
my $o;
test 'new()';
use T1;
$o = T1->new(m1 => 1, m2 => 2);
is_deeply($o, {m1 => 1, m2 => 2}, "$test : hash");
isa_ok($o, 'T1');
$o = T1->new({m1 => 1, m2 => 2});
is_deeply($o, {m1 => 1, m2 => 2}, "$test : hash ref");
isa_ok($o, 'T1');
$o = T1->new;
is_deeply($o, {}, "$test : no arguments");
test 'methods';
$o = T1->new;
can_ok($o, qw/attr class_attr dual_attr/);
test 'accessor';
$o = T1->new;
$o->m1(1);
is($o->m1, 1, "$test : attr : set and get");
T1->m2(2);
is(T1->m2, 2, "$test : class_attr : set and get");
$o->m3(3);
is($o->m3, 3, "$test : dual_attr : set and get object");
T1->m3(4);
is(T1->m3, 4, "$test : dual_attr : set and get class");
test 'accessor array';
$o = T1->new;
$o->m4_1(1);
is($o->m4_1, 1, "$test : attr : set and get 1");
$o->m4_2(1);
is($o->m4_2, 1, "$test : attr : set and get 2");
T1->m5_1(2);
is(T1->m5_1, 2, "$test : class_attr : set and get 1");
T1->m5_2(2);
is(T1->m5_2, 2, "$test : class_attr : set and get 2");
$o->m6_1(3);
is($o->m6_1, 3, "$test : dual_attr : set and get object 1");
T1->m6_1(4);
is(T1->m6_1, 4, "$test : dual_attr : set and get class 1");
$o->m6_2(3);
is($o->m6_2, 3, "$test : dual_attr : set and get object 2");
T1->m6_2(4);
is(T1->m6_2, 4, "$test : dual_attr : set and get class 2");
test 'constructor';
$o = T1->new(m1 => 1);
is($o->m1, 1, "$test : hash");
$o = T1->new({m1 => 2});
is($o->m1, 2, "$test : hash ref");
test 'default option';
$o = T1->new;
is(T1->m9, 9, "$test : class_attr");
is($o->m10, 10, "$test : dual_attr : object");
is(T1->m10, 10, "$test : dual_attr : class");
is($o->m11, 1, "$test : shortcut scalar");
is($o->m12, 9, "$test : shortcut code ref");
is(T1->m13, 'm13', "$test : shortcut scalar class_attr");
is(T1->m14, 'm14', "$test : shortcut code ref class_attr");
is(T1->m15, 'm15', "$test : shortcut scalar dual_attr from class");
is($o->m15, 'm15', "$test : shortcut scalar dual_attr from instance");
is(T1->m16, 'm16', "$test : shortcut code ref dual_attr from class");
is($o->m16, 'm16', "$test : shortcut code ref dual_attr from instance");
test 'array and default';
is($o->m18, 5, "$test : attr : first");
is($o->m19, 5, "$test : attr :second");
is(T1->m20, 6, "$test : class_attr : first");
is(T1->m21, 6, "$test : class_attr : second");
is($o->m22, 7, "$test : dual_attr : from instance : first");
is($o->m23, 7, "$test : dual_attr : from instance :second");
is(T1->m22, 7, "$test : dual_attr : from class : first");
is(T1->m23, 7, "$test : dual_attr : from class :second");
test 'inherit option hash_copy';
is_deeply(T1_2->m24, {a => 1}, "$test : subclass 1 : class");
$o = T1_2->new;
is_deeply($o->m24, {a => 1}, "$test : subclass 1 : object");
$o->m24->{b} = 1;
is_deeply(T1_2->m24, {a => 1}, "$test : subclass : no effect");
T1_2->m24->{c} = 1;
is_deeply(T1_3->m24, {a => 1, c => 1}, "$test :subclass 2 : class");
$o = T1_3->new;
is_deeply($o->m24, {a => 1, c => 1}, "$test :subclass 2 : object");
test 'inherit options array copy';
is_deeply(T1_2->m25, [1, 2], "$test : subclass 1 : class");
$o = T1_2->new;
is_deeply($o->m25, [1, 2], "$test : subclass 1 : object");
$o->m25->[2] = 3;
is_deeply(T1_2->m25, [1, 2], "$test : subclass : no effect");
T1_2->m25->[2] = 3;
is_deeply(T1_3->m25, [1, 2, 3], "$test :subclass 2 : class");
$o = T1_3->new;
is_deeply($o->m25, [1, 2, 3], "$test :subclass 2 : object");
test 'inherit options scalar copy';
is_deeply(T1_2->m26, 1, "$test : subclass 1 : class");
$o = T1_2->new;
is_deeply($o->m26, 1, "$test : subclass 1 : object");
$o->m26(3);
is_deeply(T1_2->m26, 1, "$test : subclass : no effect");
T1_2->m26(3);
is_deeply(T1_3->m26, 3, "$test :subclass 2 : class");
$o = T1_3->new;
is_deeply($o->m26, 3, "$test :subclass 2 : object");
test 'Error';
{
package Some::T2;
use base 'Object::Simple';
eval{__PACKAGE__->attr(m1 => {})};
Test::More::like($@, qr/Default has to be a code reference or constant value.*Some::T2::m1/,
'default is not scalar or code ref');
eval{__PACKAGE__->class_attr('m2', inherit => 'no')};
Test::More::like($@, qr/\Q'inherit' opiton must be 'scalar_copy', 'array_copy', 'hash_copy', or code reference (Some::T2::m2)/,
'invalid inherit options');
eval{__PACKAGE__->class_attr('m4', no => 1)};
Test::More::like($@, qr/\Q'no' is invalid option/, "$test : invalid option : class_attr");
eval{__PACKAGE__->dual_attr('m5', no => 1)};
Test::More::like($@, qr/\Q'no' is invalid option/, "$test : invalid option : dual_attr");
}
test 'Method export';
{
package T3;
use Object::Simple qw/new attr class_attr dual_attr/;
__PACKAGE__->attr('m1');
__PACKAGE__->class_attr('m2');
__PACKAGE__->dual_attr('m3');
}
$o = T3->new;
$o->m1(1);
T3->m2(2);
$o->m3(3);
is($o->m1, 1, "$test : export attr");
is(T3->m2, 2, "$test : export class_attr");
is($o->m3, 3, "$test : export dual_attr");
test 'Method export error';
{
package T4;
eval "use Object::Simple 'none';";
}
like($@, qr/'none' is invalid option/, "$test");
test 'Inherit class_attr';
is_deeply(T1->m27, {a1 => 1}, "$test : no effect : hash");
is_deeply(T1_2->m27, {a1 => 1, a2 => 2}, "$test : inhert : hash");
is_deeply(T1->m28, [1], "$test : no effect : hash");
is_deeply(T1_2->m28, [1, 2], "$test : inherit : hash");
is(T1->m29, 5, "$test: inherit : sub ref default");
test 'Normal accessor';
$o = T1->new;
$o->m1(1);
is($o->m1, 1, "$test : set and get");
is($o->m1(1), $o, "$test : set return");
test 'Normal accessor with default';
$o = T1->new;
$o->m11(2);
is($o->m11, 2, "$test : set and get");
is($o->m11(2), $o, "$test : set return");
$o = T1->new;
is($o->m11, 1, "$test : default");
is($o->m12, 9, "$test : default sub reference");
test 'Normal accessor with inherit';
$o = T1->new;
$o->m24(1);
is($o->m24, 1, "$test : set and get");
is($o->m24(1), $o, "$test : set return");
test 'Class accessor';
T1->m2(1);
is(T1->m2, 1, "$test : set and get");
is(T1->m2(1), 'T1', "$test : set return");
eval {T1->m2(1, 2)};
like($@, qr/\QOne argument must be passed to "T1::m2()"/, "$test : One argument must be passed");
eval {T1->new->m2};
like($@, qr/T1::m2 must be called from class/, "$test : must be called from class");
test 'Class accessor with default';
T1->m13(2);
is(T1->m13, 2, "$test : set and get");
is(T1->m13(2), 'T1', "$test : set return");
eval {T1->m13(1, 2)};
like($@, qr/\QOne argument must be passed to "T1::m13()"/, "$test : One argument must be passed");
delete $T1::CLASS_ATTRS->{'m13'};
is(T1->m13, 'm13', "$test : default");
is(T1->m14, 'm14', "$test : default sub reference");
eval {T1->new->m13};
like($@, qr/T1::m13 must be called from class/, "$test : must be called from class");
test 'Class accessor with inherit';
T1->m24(1);
is(T1->m24, 1, "$test : set and get");
is(T1->m24(1), 'T1', "$test : set return");
eval {T1->m24(1, 2)};
like($@, qr/\QOne argument must be passed to "T1::m24()"/, "$test : One argument must be passed");
eval{T1->new->m27};
like($@, qr/T1::m27 must be called from class/, "$test : must be called from class");
test 'new()';
$o = T1->new(m1 => 1);
isa_ok($o, 'T1');
is($o->m1, 1, "$test : from class : hash");
$o = T1->new({m1 => 1});
isa_ok($o, 'T1');
is($o->m1, 1, "$test : from class : hash ref");
$o = $o->new(m1 => 1);
isa_ok($o, 'T1');
is($o->m1, 1, "$test : from object : hash");
$o = $o->new({m1 => 1});
isa_ok($o, 'T1');
is($o->m1, 1, "$test : from object : hash ref");
test 'default';
$o = T1->new;
is($o->m31, 5, "$test : self : attr");
is(T1->m32, 5, "$test : self : class_attr");
test 'easy definition';
$o = T1->new;
ok($o->can('m33'), $test);
ok($o->can('m34'), $test);
is($o->m35, 1, $test);
is($o->m36, 5, $test);
is($o->m37, 1, $test);
is($o->m38, 5, $test);
test 'attr from object';
$o = T1->new;
$o->attr('from_object');
ok($o->can('from_object'), $test);