use strict;
use warnings;
BEGIN {
eval { require Want; };
if ($@ || $Want::VERSION < 0.12) {
print("1..0 # Skip Needs Want v0.12 or later\n");
exit(0);
}
}
use Test::More 'tests' => 163;
use Scalar::Util;
package Baz; {
use Object::InsideOut;
sub me
{
my $self = shift;
return ("Baz($$self)");
}
}
package Foo; {
use Object::InsideOut;
# Separate get and set accessors
my @foo1 :Field('Std' => 'foo1', 'Return' => 'NEW');
my @foo2 :Field('Get' => 'get_foo2', 'set' => 'set_foo2', 'Return' => 'OLD');
my @foo3 :Field('STANDARD' => 'foo3', 'Return' => 'SELF');
# Combined get+set accessor
my @bar1 :Field('Combo' => 'bar1', 'Return' => 'new');
my @bar2 :Field('Acc' => 'bar2', 'Return' => 'Prev');
my @bar3 :Field('get_set' => 'bar3', 'Return' => 'obj');
# Type checking
my @baz1 :Field('Acc' => 'baz1', 'Return' => 'new', 'Type' => 'Baz');
my @baz2 :Field('Acc' => 'baz2', 'Return' => 'old', 'Type' => 'Baz');
my @baz3 :Field('Acc' => 'baz3', 'Return' => 'obj', 'Type' => 'Baz');
my @num1 :Field('Acc' => 'num1', 'Return' => 'new', 'Type' => 'num');
my @num2 :Field('Acc' => 'num2', 'Return' => 'old', 'Type' => 'num');
my @num3 :Field('Acc' => 'num3', 'Return' => 'obj', 'Type' => 'num');
sub me
{
my $self = shift;
return ("Foo($$self)");
}
}
package main;
sub change_it
{
$_[0] = $_[1];
}
sub check_it
{
my ($x, $y) = @_;
if ($x eq $y) {
ok(1, 'Checked');
} else {
is($x, $y, 'Check failed');
}
}
MAIN:
{
my $b1 = Baz->new();
my $b2 = Baz->new();
my $obj = Foo->new();
ok($b1 && $b2 && $obj, 'Objects created');
can_ok($obj, qw(new clone DESTROY CLONE
get_foo1 set_foo1 get_foo2 set_foo2 get_foo3 set_foo3
bar1 bar2 bar3));
# set - return new
eval { $obj->set_foo1(); };
like($@, qr/Missing arg/ => 'rvalue set needs arg');
$obj->set_foo1('val');
is($obj->get_foo1(), 'val' => 'rvalue set void');
eval { $obj->get_foo1(); };
is($@, '' => 'rvalue get void');
my $val = $obj->set_foo1($b1);
is($val, $b1 => 'rvalue set returns new');
my $val2 = $obj->get_foo1();
is($val2, $b1 => 'rvalue get');
eval { $obj->set_foo1() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
change_it($obj->set_foo1('Bert'), 'Mike');
is($obj->get_foo1(), 'Bert' => 'lvalue does not work');
check_it($obj->set_foo1('Ralph'), 'Ralph');
$obj->set_foo1($b1);
eval { $val = $obj->set_foo1()->me(); };
like($@, qr/Missing arg/ => 'chain set needs arg');
$val = $obj->set_foo1('bork')->me();
is($val, 'Foo(1)' => 'chain self');
$val = $obj->set_foo1($b2)->me();
is($val, 'Baz(2)' => 'chain new object');
# set - return old
eval { $obj->set_foo2(); };
like($@, qr/Missing arg/ => 'rvalue set needs arg');
$obj->set_foo2('val');
is($obj->get_foo2(), 'val' => 'rvalue set void');
eval { $obj->get_foo2(); };
is($@, '' => 'rvalue get void');
$obj->set_foo2($b2);
$val = $obj->set_foo2($b1);
is($val, $b2 => 'rvalue set returns old');
$val2 = $obj->get_foo2();
is($val2, $b1 => 'rvalue get');
eval { $obj->set_foo2() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
eval { $obj->set_foo2() =~ s/er/re/; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
change_it($obj->set_foo2('Bert'), 'Mike');
is($obj->get_foo2(), 'Bert' => 'lvalue does not work');
check_it($obj->set_foo2('Ralph'), 'Bert');
$obj->set_foo2($b1);
eval { $val = $obj->set_foo2()->me(); };
like($@, qr/Missing arg/ => 'chain set needs arg');
$obj->set_foo2('bork');
$val = $obj->set_foo2('bar')->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->get_foo2(), 'bar' => 'chain set');
$obj->set_foo2($b1);
$val = $obj->set_foo2($b2)->me();
is($val, 'Baz(1)' => 'chain old object');
is($obj->get_foo2(), $b2 => 'chain set');
# set - return self
eval { $obj->set_foo3(); };
like($@, qr/Missing arg/ => 'rvalue set needs arg');
$obj->set_foo3('val');
is($obj->get_foo3(), 'val' => 'rvalue set void');
eval { $obj->get_foo3(); };
is($@, '' => 'rvalue get void');
$val = $obj->set_foo3($b1);
is($val, $obj => 'rvalue set returns self');
$val2 = $obj->get_foo3();
is($val2, $b1 => 'rvalue get');
eval { $obj->set_foo3() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
my $obj_old = $obj;
change_it($obj->set_foo3('Bert'), 'Mike');
is($obj, $obj_old => 'lvalue does not work');
is($obj->get_foo3(), 'Bert' => 'Change did set');
check_it($obj->set_foo3('Ralph'), $obj);
is($obj->get_foo3(), 'Ralph' => 'Check did set');
$obj->set_foo3($b1);
is($obj->get_foo3()->me(), 'Baz(1)' => 'chain get');
eval { $val = $obj->set_foo3()->me(); };
like($@, qr/Missing arg/ => 'chain set needs arg');
$val = $obj->set_foo3('bork')->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->get_foo3(), 'bork' => 'chain set');
$val = $obj->set_foo3($b2)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->get_foo3(), $b2 => 'chain set');
# get_set - return new
$obj->bar1('val');
is($obj->bar1(), 'val' => 'rvalue set void');
eval { $obj->bar1(); };
is($@, '' => 'rvalue get void');
$val = $obj->bar1($b1);
is($val, $b1 => 'rvalue set returns new');
$val2 = $obj->bar1();
is($val2, $b1 => 'rvalue get');
eval { $obj->bar1() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
eval { $obj->bar1() =~ s/er/re/; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
change_it($obj->bar1(), 'Fred');
is($obj->bar1(), $b1 => 'lvalue does not work');
check_it($obj->bar1(), $b1);
change_it($obj->bar1('Bert'), 'Mike');
is($obj->bar1(), 'Bert' => 'lvalue does not work');
check_it($obj->bar1('Ralph'), 'Ralph');
$obj->bar1($b1);
is($obj->bar1(), $b1 => 'set');
$val = $obj->bar1()->me();
is($val, 'Baz(1)' => 'chain get');
$val = $obj->bar1('bork')->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->bar1(), 'bork' => 'chain set');
$val = $obj->bar1($b2)->me();
is($val, 'Baz(2)' => 'chain new object');
is($obj->bar1(), $b2 => 'chain set');
# get_set - return old
$obj->bar2('val');
is($obj->bar2(), 'val' => 'rvalue set void');
eval { $obj->bar2(); };
is($@, '' => 'rvalue get void');
$obj->bar2($b2);
$val = $obj->bar2($b1);
is($val, $b2 => 'rvalue set returns old');
$val2 = $obj->bar2();
is($val2, $b1 => 'rvalue get');
eval { $obj->bar2() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
change_it($obj->bar2(), 'Fred');
is($obj->bar2(), $b1 => 'lvalue does not work');
check_it($obj->bar2(), $b1);
change_it($obj->bar2('Bert'), 'Mike');
is($obj->bar2(), 'Bert' => 'lvalue probably does not work');
check_it($obj->bar2($b1), 'Bert');
is($obj->bar2(), $b1 => 'set');
$val = $obj->bar2()->me();
is($val, 'Baz(1)' => 'chain get');
$obj->bar2('bork');
$val = $obj->bar2('bar')->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->bar2(), 'bar' => 'chain set');
$obj->bar2($b1);
$val = $obj->bar2($b2)->me();
is($val, 'Baz(1)' => 'chain old object');
is($obj->bar2(), $b2 => 'chain set');
# get_set - return self
$obj->bar3('val');
is($obj->bar3(), 'val' => 'rvalue set void');
eval { $obj->bar3(); };
is($@, '' => 'rvalue get void');
$val = $obj->bar3($b1);
is($val, $obj => 'rvalue set returns self');
$val2 = $obj->bar3();
is($val2, $b1 => 'rvalue get');
change_it($obj->bar3(), 'Fred');
is($obj->bar3(), $b1 => 'lvalue does not work');
check_it($obj->bar3(), $b1);
change_it($obj->bar3('Bert'), 'Mike');
is(ref($obj), 'Foo' => 'lvalue does not work');
is($obj->bar3(), 'Bert' => 'Change did set');
check_it($obj->bar3('Ralph'), $obj);
is($obj->bar3(), 'Ralph' => 'Check did set');
$obj->bar3($b1);
is($obj->bar3(), $b1 => 'set');
$val = $obj->bar3()->me();
is($val, 'Baz(1)' => 'chain get');
$val = $obj->bar3('bork')->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->bar3(), 'bork' => 'chain set');
$val = $obj->bar3($b2)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->bar3(), $b2 => 'chain set');
# get_set - return new - type class
$obj->baz1($b1);
is($obj->baz1(), $b1 => 'rvalue set void');
eval { $obj->baz1('val'); };
like($@, qr/must be of type 'Baz'/ => 'rvalue set void - bad');
eval { $obj->baz1(); };
is($@, '' => 'rvalue get void');
$val = $obj->baz1($b1);
is($val, $b1 => 'rvalue set returns new');
$val2 = $obj->baz1();
is($val2, $b1 => 'rvalue get');
eval { $obj->baz1() = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
eval { $obj->baz1($obj) = $b2; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
is($obj->baz1(), $b1 => 'not changed');
eval { $obj->baz1() =~ s/Baz/Boing/; }; # Evil
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
is($obj->baz1(), $b1 => 'not changed');
change_it($obj->baz1(), 'Fred');
is($obj->baz1(), $b1 => 'lvalue does not work');
check_it($obj->baz1(), $b1);
change_it($obj->baz1($b1), 'Mike');
is($obj->baz1(), $b1 => 'lvalue does not work');
check_it($obj->baz1($b2), $b2);
$val = $obj->baz1()->me();
is($val, 'Baz(2)' => 'chain get');
$val = $obj->baz1($b1)->me();
is($val, 'Baz(1)' => 'chain new object');
is($obj->baz1, $b1 => 'chain set');
# get_set - return old - type class
$obj->baz2($b2);
is($obj->baz2(), $b2 => 'rvalue set void');
eval { $obj->baz2(); };
is($@, '' => 'rvalue get void');
$val = $obj->baz2($b1);
is($val, $b2 => 'rvalue set returns old');
$val2 = $obj->baz2();
is($val2, $b1 => 'rvalue get');
change_it($obj->baz2(), 'Fred');
is($obj->baz2(), $b1 => 'lvalue does not work');
check_it($obj->baz2(), $b1);
change_it($obj->baz2($b2), 'Mike');
is($obj->baz2(), $b2 => 'lvalue does not work');
check_it($obj->baz2($b1), $b2);
is($obj->baz2(), $b1 => 'set');
$val = $obj->baz2()->me();
is($val, 'Baz(1)' => 'chain get');
$val = $obj->baz2($b2)->me();
is($val, 'Baz(1)' => 'chain old object');
is($obj->baz2(), $b2 => 'chain set');
# get_set - return self - type class
$obj->baz3($b1);
is($obj->baz3(), $b1 => 'rvalue set void');
eval { $obj->baz3(); };
is($@, '' => 'rvalue get void');
$val = $obj->baz3($b2);
is($val, $obj => 'rvalue set returns self');
$val2 = $obj->baz3();
is($val2, $b2 => 'rvalue get');
change_it($obj->baz3(), 'Fred');
is($obj->baz3(), $b2 => 'lvalue does not work');
check_it($obj->baz3(), $b2);
change_it($obj->baz3($b1), 'Mike');
is($obj->baz3(), $b1 => 'lvalue does not work');
check_it($obj->baz3($b2), $obj);
is($obj->baz3(), $b2 => 'Check did set');
$val = $obj->baz3()->me();
is($val, 'Baz(2)' => 'chain get');
$val = $obj->baz3($b1)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->baz3(), $b1 => 'chain set');
# get_set - return new - type num
$obj->num1(1);
is($obj->num1(), 1 => 'rvalue set void');
eval { $obj->num1($b1); };
like($@, qr/must be a number/ => 'rvalue set void - bad');
eval { $obj->num1(); };
is($@, '' => 'rvalue get void');
$val = $obj->num1(2);
is($val, 2 => 'rvalue set returns new');
$val2 = $obj->num1();
is($val2, 2 => 'rvalue get');
eval { $obj->num1('bork') = 3; };
like($@, qr/non-lvalue subroutine/ => 'not lvalue');
change_it($obj->num1(), 'Fred');
is($obj->num1(), 2 => 'lvalue does not work');
check_it($obj->num1(), 2);
change_it($obj->num1(4), 'Mike');
is($obj->num1(), 4 => 'lvalue does not work');
check_it($obj->num1(5), 5);
eval { $val = $obj->num1()->me(); };
like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');
$val = $obj->num1(8)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->num1(), 8 => 'chain set');
# get_set - return old - type num
$obj->num2(1);
is($obj->num2(), 1 => 'rvalue set void');
eval { $obj->num2(); };
is($@, '' => 'rvalue get void');
$val = $obj->num2(2);
is($val, 1 => 'rvalue set returns old');
$val2 = $obj->num2();
is($val2, 2 => 'rvalue get');
change_it($obj->num2(5), 'Mike');
is($obj->num2(), 5 => 'lvalue does not work');
check_it($obj->num2(6), 5);
$val = $obj->num2(7)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->num2(), 7 => 'chain set');
# get_set - return self - type num
$obj->num3(1);
is($obj->num3(), 1 => 'rvalue set void');
eval { $obj->num3(); };
is($@, '' => 'rvalue get void');
$val = $obj->num3(2);
is($val, $obj => 'rvalue set returns self');
is($obj->num3(), 2 => 'rvalue set');
$val2 = $obj->num3();
is($val2, 2 => 'rvalue get');
change_it($obj->num3(5), 'Mike');
is($obj->num3(), 5 => 'lvalue does not work');
check_it($obj->num3(6), $obj);
is($obj->num3(), 6 => 'Check did set');
eval { $val = $obj->num3()->me(); };
like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');
$val = $obj->num3(7)->me();
is($val, 'Foo(1)' => 'chain self');
is($obj->num3(), 7 => 'chain set');
}
exit(0);
__END__
:LVALUE set get_set
$obj->foo('val'); rvalue set void
$obj->foo(); ERR get rvalue get void
my $x = $obj->foo('val'); rvalue set return
NEW
OLD
SELF
my $x = $obj->foo(); ERR get rvalue get
$obj->foo() = 'val'; lvalue assign
$obj->foo('ignored') = 'val'; lvalue assign
$obj->foo() =~ s/x/y/; fld lvalue re
bar($obj->foo()); fld lvalue
change_it
check_it
bar($obj->foo('val')); lvalue + arg
change_it
check_it
NEW fld
OLD ret
SELF obj
$obj->foo()->bar(); ERR fld lvalue + want(obj)
$obj->foo('val')->bar(); lvalue + arg + want(obj)
NEW fld/obj
OLD ret/obj
SELF obj
Non-lvalue
$obj->foo('val'); rvalue set void
$obj->foo(); ERR get rvalue get void
my $x = $obj->foo('val'); rvalue set return
NEW
OLD
SELF
my $x = $obj->foo(); ERR get rvalue get
$obj->foo() = 'val'; ERR
$obj->foo('ignored') = 'val'; ERR
$obj->foo() =~ s/x/y/; ERR
bar($obj->foo()); ERR get
bar($obj->foo('val'));
NEW fld
OLD ret
SELF obj
$obj->foo()->bar(); ERR get
$obj->foo('val')->bar();
NEW fld/obj
OLD ret/obj
SELF obj
# EOF