use strict;
use warnings;
BEGIN {
if ($] < 5.008) {
print("1..0 # Skip :lvalue requires Perl 5.8.0 or later\n");
exit(0);
}
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' => 182;
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', 'LValue' => 1, 'Return' => 'NEW');
my @foo2 :Field('Get' => 'get_foo2', 'set' => 'set_foo2', 'lv' => 1, 'Return' => 'OLD');
my @foo3 :Field('STANDARD' => 'foo3', 'LVALUE' => 1, 'Return' => 'SELF');
# Combined get+set accessor
my @bar1 :Field('LValue' => 'bar1', 'Return' => 'new');
my @bar2 :Field('Acc' => 'bar2', 'lvalue' => 1, 'Return' => 'Prev');
my @bar3 :Field('get_set' => 'bar3', 'lv' => 1, 'Return' => 'obj');
# Type checking
my @baz1 :Field('lv' => 'baz1', 'Return' => 'new', 'Type' => 'Baz');
my @baz2 :Field('lv' => 'baz2', 'Return' => 'old', 'Type' => 'Baz');
my @baz3 :Field('lv' => 'baz3', 'Return' => 'obj', 'Type' => 'Baz');
my @num1 :Field('lv' => 'num1', 'Return' => 'new', 'Type' => 'num');
my @num2 :Field('lv' => 'num2', 'Return' => 'old', 'Type' => 'num');
my @num3 :Field('lv' => 'num3', 'Return' => 'obj', 'Type' => 'num');
my @bork
:Field
:Type(Array_Ref(HASH))
:LV(bork);
my @zork
:Field
:Type(ScalarRef)
:LV(zork);
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');
$obj->set_foo1() = $b2;
is($obj->get_foo1(), $b2 => 'lvalue assign');
$obj->set_foo1('foo') = 'Bert';
is($obj->get_foo1(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->set_foo1() =~ s/er/re/;
is($obj->get_foo1(), 'Bret' => 'lvalue re');
change_it($obj->set_foo1(), 'Fred');
is($obj->get_foo1(), 'Fred' => 'lvalue');
check_it($obj->set_foo1(), 'Fred');
change_it($obj->set_foo1('Bert'), 'Mike');
is($obj->get_foo1(), 'Mike' => 'lvalue + arg new');
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');
$obj->set_foo2() = $b2;
is($obj->get_foo2(), $b2 => 'lvalue assign');
$obj->set_foo2('foo') = 'Bert';
is($obj->get_foo2(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->set_foo2() =~ s/er/re/;
is($obj->get_foo2(), 'Bret' => 'lvalue re');
change_it($obj->set_foo2(), 'Fred');
is($obj->get_foo2(), 'Fred' => 'lvalue');
check_it($obj->set_foo2(), 'Fred');
change_it($obj->set_foo2('Bert'), 'Mike');
is($obj->get_foo2(), 'Bert' => 'lvalue + arg old');
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');
$obj->set_foo2($b1);
$val = $obj->set_foo2($b2)->me();
is($val, 'Baz(1)' => 'chain old object');
# 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');
$obj->set_foo3() = $b2;
is($obj->get_foo3(), $b2 => 'lvalue assign');
$obj->set_foo3('foo') = 'Bert';
is($obj->get_foo3(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->set_foo3() =~ s/er/re/;
is($obj->get_foo3(), 'Bret' => 'lvalue re');
change_it($obj->set_foo3(), 'Fred');
is($obj->get_foo3(), 'Fred' => 'lvalue');
check_it($obj->set_foo3(), 'Fred');
my $obj_old = $obj;
change_it($obj->set_foo3('Bert'), 'Mike');
is($obj, 'Mike' => 'lvalue + arg self');
$obj = $obj_old;
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);
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');
$val = $obj->set_foo3($b2)->me();
is($val, 'Foo(1)' => 'chain self');
# 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');
$obj->bar1() = $b2;
is($obj->bar1(), $b2 => 'lvalue assign');
$obj->bar1('foo') = 'Bert';
is($obj->bar1(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->bar1() =~ s/er/re/;
is($obj->bar1(), 'Bret' => 'lvalue re');
change_it($obj->bar1(), 'Fred');
is($obj->bar1(), 'Fred' => 'lvalue');
check_it($obj->bar1(), 'Fred');
change_it($obj->bar1('Bert'), 'Mike');
is($obj->bar1(), 'Mike' => 'lvalue + arg new');
check_it($obj->bar1('Ralph'), 'Ralph');
$obj->bar1($b1);
$val = $obj->bar1()->me();
is($val, 'Baz(1)' => 'chain get');
$val = $obj->bar1('bork')->me();
is($val, 'Foo(1)' => 'chain self');
$val = $obj->bar1($b2)->me();
is($val, 'Baz(2)' => 'chain new object');
# 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');
$obj->bar2() = $b2;
is($obj->bar2(), $b2 => 'lvalue assign');
$obj->bar2('foo') = 'Bert';
is($obj->bar2(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->bar2() =~ s/er/re/;
is($obj->bar2(), 'Bret' => 'lvalue re');
change_it($obj->bar2(), 'Fred');
is($obj->bar2(), 'Fred' => 'lvalue');
check_it($obj->bar2(), 'Fred');
change_it($obj->bar2('Bert'), 'Mike');
is($obj->bar2(), 'Bert' => 'lvalue + arg old');
check_it($obj->bar2('Ralph'), 'Bert');
$obj->bar2($b1);
$val = $obj->bar2()->me();
is($val, 'Baz(1)' => 'chain get');
$obj->bar2('bork');
$val = $obj->bar2('bar')->me();
is($val, 'Foo(1)' => 'chain self');
$obj->bar2($b1);
$val = $obj->bar2($b2)->me();
is($val, 'Baz(1)' => 'chain old object');
# 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');
$obj->bar3() = $b2;
is($obj->bar3(), $b2 => 'lvalue assign');
$obj->bar3('foo') = 'Bert';
is($obj->bar3(), 'Bert' => 'lvalue assign (arg ignored)');
$obj->bar3() =~ s/er/re/;
is($obj->bar3(), 'Bret' => 'lvalue re');
change_it($obj->bar3(), 'Fred');
is($obj->bar3(), 'Fred' => 'lvalue');
check_it($obj->bar3(), 'Fred');
$obj_old = $obj;
change_it($obj->bar3('Bert'), 'Mike');
is($obj, 'Mike' => 'lvalue + arg self');
$obj = $obj_old;
is($obj->bar3(), 'Bert' => 'Change did set');
check_it($obj->bar3('Ralph'), $obj);
is($obj->bar3(), 'Ralph' => 'Check did set');
$obj->bar1($b1);
$val = $obj->bar1()->me();
is($val, 'Baz(1)' => 'chain get');
$val = $obj->bar3('bork')->me();
is($val, 'Foo(1)' => 'chain self');
$val = $obj->bar3($b2)->me();
is($val, 'Foo(1)' => 'chain self');
# 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');
$obj->baz1() = $b2;
is($obj->baz1(), $b2 => 'lvalue assign');
eval { $obj->baz1() = 'val'; };
like($@, qr/must be of type 'Baz'/ => 'lvalue assign - bad');
$obj->baz1($obj) = $b2;
is($obj->baz1(), $b2 => 'lvalue assign (arg ignored)');
eval { $obj->baz1() =~ s/Baz/Boing/; }; # Evil
ok(! Scalar::Util::blessed($obj->baz1()) => 'lvalue re');
like($obj->baz1(), qr/^Boing=SCALAR\(/ => 'lvalue re');
change_it($obj->baz1(), 'Fred');
is($obj->baz1(), 'Fred' => 'lvalue - no type check');
check_it($obj->baz1(), 'Fred');
change_it($obj->baz1($b1), 'Mike');
is($obj->baz1(), 'Mike' => 'lvalue + arg new - no type check');
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');
# 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');
$obj->baz2() = $b2;
is($obj->baz2(), $b2 => 'lvalue assign');
$obj->baz2($obj) = $b2;
is($obj->baz2(), $b2 => 'lvalue assign (arg ignored)');
change_it($obj->baz2(), 'Fred');
is($obj->baz2(), 'Fred' => 'lvalue - no type check');
check_it($obj->baz2(), 'Fred');
change_it($obj->baz2($b1), 'Mike');
is($obj->baz2(), $b1 => 'lvalue + arg old');
check_it($obj->baz2($b2), $b1);
$val = $obj->baz2()->me();
is($val, 'Baz(2)' => 'chain get');
$val = $obj->baz2($b1)->me();
is($val, 'Baz(2)' => 'chain old object');
# 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');
$obj->baz3() = $b1;
is($obj->baz3(), $b1 => 'lvalue assign');
$obj->baz3($obj) = $b2;
is($obj->baz3(), $b2 => 'lvalue assign (arg ignored)');
change_it($obj->baz3(), 'Fred');
is($obj->baz3(), 'Fred' => 'lvalue - no type check');
check_it($obj->baz3(), 'Fred');
$obj_old = $obj;
change_it($obj->baz3($b1), 'Mike');
is($obj, 'Mike' => 'lvalue + arg self - no type check');
$obj = $obj_old;
is($obj->baz3(), $b1 => 'Change did set');
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');
# 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');
$obj->num1() = 3;
is($obj->num1(), 3 => 'lvalue assign');
eval { $obj->num1() = 'val'; };
like($@, qr/must be a number/ => 'lvalue assign - bad');
$obj->num1('bork') = 4;
is($obj->num1(), 4 => 'lvalue assign (arg ignored)');
$obj->num1(5);
eval { $obj->num1() =~ s/5/Boing/; }; # Evil
is($obj->num1(), 'Boing' => 'lvalue re');
change_it($obj->num1(), 'Fred');
is($obj->num1(), 'Fred' => 'lvalue - no type check');
check_it($obj->num1(), 'Fred');
change_it($obj->num1(6), 'Mike');
is($obj->num1(), 'Mike' => 'lvalue + arg new - no type check');
check_it($obj->num1(7), 7);
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');
$obj->num2() = 3;
is($obj->num2(), 3 => 'lvalue assign');
$obj->num2('bork') = 4;
is($obj->num2(), 4 => 'lvalue assign (arg ignored)');
change_it($obj->num2(), 'Fred');
is($obj->num2(), 'Fred' => 'lvalue - no type check');
check_it($obj->num2(), 'Fred');
change_it($obj->num2(5), 'Mike');
is($obj->num2(), 5 => 'lvalue + arg old');
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');
$obj->num3() = 3;
is($obj->num3(), 3 => 'lvalue assign');
$obj->num3($obj) = 4;
is($obj->num3(), 4 => 'lvalue assign (arg ignored)');
change_it($obj->num3(), 'Fred');
is($obj->num3(), 'Fred' => 'lvalue - no type check');
check_it($obj->num3(), 'Fred');
$obj_old = $obj;
change_it($obj->num3(5), 'Mike');
is($obj, 'Mike' => 'lvalue + arg self - no type check');
$obj = $obj_old;
is($obj->num3(), 5 => 'Change did set');
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');
$obj->bork() = [ {a=>5,b=>'foo'}, {}, {99=>'bork'} ];
is_deeply($obj->bork(), [ {a=>5,b=>'foo'}, {}, {99=>'bork'} ]
=> 'lv array_ref subtype=hash');
my $x = 42;
$obj->zork() = \$x;
is($obj->zork(), \$x => 'lv scalar_ref');
my $y = $obj->zork();
is($$y, 42 => 'lv scalar_ref value')
}
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