#!perl -w
# $Id: base.t 3872 2008-05-09 19:36:23Z david $
use strict;
use Test::More tests => 99;
BEGIN { use_ok('Class::Delegator') }
FOO: {
package MyTest::Foo;
sub new { bless {} }
sub bar {
my $self = shift;
return $self->{bar} unless @_;
$self->{bar} = shift;
};
sub try {
my $self = shift;
return $self->{try} unless @_;
$self->{try} = shift;
};
}
can_ok 'MyTest::Foo' => 'new';
can_ok 'MyTest::Foo' => 'bar';
can_ok 'MyTest::Foo' => 'try';
SIMPLE: {
package MyTest::Simple;
sub new { bless { foo => MyTest::Foo->new } }
use Class::Delegator
send => 'bar',
to => '{foo}',
;
}
can_ok 'MyTest::Simple' => 'bar';
ok my $d = MyTest::Simple->new, "Construct new simple object";
is $d->bar, $d->{foo}->bar, "Make sure the simple values are the same";
ok $d->bar('hello'), "Set the value via the simple delegate";
is $d->bar, 'hello', "Make sure that the simple attribute was set";
is $d->{foo}->bar, 'hello', "And that it is in the simple contained object";
TWOSIMPLE: {
package MyTest::TwoSimple;
sub new { bless { foo => MyTest::Foo->new, foo2 => MyTest::Foo->new } }
use Class::Delegator
send => 'bar',
to => '{foo}',
send => 'try',
to => '{foo2}',
;
}
can_ok 'MyTest::TwoSimple' => 'bar';
can_ok 'MyTest::TwoSimple' => 'try';
ok $d = MyTest::TwoSimple->new, "Construct new two simple object";
is $d->bar, $d->{foo}->bar, "Make sure the bar simple values are the same";
ok $d->bar('hello'), "Set the value via the bar simple delegate";
is $d->bar, 'hello', "Make sure that the bar simple attribute was set";
is $d->{foo}->bar, 'hello', "And that it is in the bar simple contained object";
isnt $d->bar, $d->try, "Make sure that the two values are different";
is $d->try, $d->{foo2}->try, "Make sure the try simple values are the same";
ok $d->try('fee'), "Set the value via the try simple delegate";
is $d->try, 'fee', "Make sure that the try simple attribute was set";
is $d->{foo2}->try, 'fee', "And that it is in the try simple contained object";
isnt $d->bar, $d->try, "Make sure that the two values are still different";
AS: {
package MyTest::As;
sub new { bless { foo => MyTest::Foo->new } }
use Class::Delegator
send => 'yow',
to => '{foo}',
as => 'bar',
;
}
ok ! MyTest::As->can('bar'), "MyTest::As cannot 'bar'";
can_ok 'MyTest::As' => 'yow';
ok $d = MyTest::As->new, "Construct new as object";
is $d->yow, $d->{foo}->bar, "Make sure the as values are the same";
ok $d->yow('hello'), "Set the as value via the delegate";
is $d->yow, 'hello', "Make sure that the as attribute was set";
is $d->{foo}->bar, 'hello', "And that it is in the as contained object";
METHOD: {
package MyTest::Method;
sub new { bless { foo => MyTest::Foo->new } }
sub foo { shift->{foo} }
use Class::Delegator
send => 'bar',
to => 'foo',
;
}
can_ok 'MyTest::Method' => 'bar';
ok $d = MyTest::Method->new, "Construct new meth object";
is $d->bar, $d->foo->bar, "Make sure the meth values are the same";
ok $d->bar('hello'), "Set the value via the meth delegate";
is $d->bar, 'hello', "Make sure that the meth attribute was set";
is $d->foo->bar, 'hello', "And that it is in the contained object";
ARRAY: {
package MyTest::Array;
sub new { bless [ MyTest::Foo->new ] }
use Class::Delegator
send => 'bar',
to => '[0]',
;
}
can_ok 'MyTest::Array' => 'bar';
ok $d = MyTest::Array->new, "Construct new array object";
is $d->bar, $d->[0]->bar, "Make sure the array values are the same";
ok $d->bar('hello'), "Set the value via the array delegate";
is $d->bar, 'hello', "Make sure that the array attribute was set";
is $d->[0]->bar, 'hello', "And that it is in the contained object";
MULTI: {
package MyTest::Multi;
sub new { bless { foo => MyTest::Foo->new } }
use Class::Delegator
send => [qw(bar try)],
to => '{foo}',
;
}
can_ok 'MyTest::Multi' => 'bar';
can_ok 'MyTest::Multi' => 'try';
ok $d = MyTest::Multi->new, "Construct new multi object";
is $d->bar, $d->{foo}->bar, "Make sure the bar values are the same";
ok $d->bar('hello'), "Set the value via the bar delegate";
is $d->bar, 'hello', "Make sure that the bar attribute was set";
is $d->{foo}->bar, 'hello', "And that it is in the foo contained object";
is $d->try, $d->{foo}->try, "Make sure the try values are the same";
ok $d->try('hello'), "Set the value via the try delegate";
is $d->try, 'hello', "Make sure that the try attribute was set";
is $d->{foo}->try, 'hello', "And that it is in the foo contained object";
MULTIAS: {
package MyTest::MultiAs;
sub new { bless { foo => MyTest::Foo->new } }
use Class::Delegator
send => [qw(rab yrt)],
to => '{foo}',
as => [qw(bar try)],
;
}
can_ok 'MyTest::MultiAs' => 'rab';
can_ok 'MyTest::MultiAs' => 'yrt';
ok $d = MyTest::MultiAs->new, "Construct new multi object";
is $d->rab, $d->{foo}->bar, "Make sure the rab values are the same";
ok $d->rab('hello'), "Set the value via the rab delegate";
is $d->rab, 'hello', "Make sure that the rab attribute was set";
is $d->{foo}->bar, 'hello', "And that it is in the foo contained object";
is $d->yrt, $d->{foo}->try, "Make sure the yrt values are the same";
ok $d->yrt('hello'), "Set the value via the yrt delegate";
is $d->yrt, 'hello', "Make sure that the yrt attribute was set";
is $d->{foo}->try, 'hello', "And that it is in the foo contained object";
MULTITO: {
package MyTest::MultiTo;
sub new { bless { foo => MyTest::Foo->new, bat => MyTest::Foo->new } }
use Class::Delegator
send => 'bar',
to => ['{foo}', '{bat}'],
;
}
can_ok 'MyTest::MultiTo' => 'bar';
ok $d = MyTest::MultiTo->new, "Construct new MultiTo object";
is $d->{foo}->bar, undef, "Check that foo's bar is undef";
is $d->{bat}->bar, undef, "Check that bat's bar is undef";
ok $d->bar('yo'), "Set bar_try to 'yo'";
is $d->{foo}->bar, 'yo', "Check that foo's bar is now 'yo'";
is $d->{bat}->bar, 'yo', "Check that bat's bar is now 'yow'";
# Try getting the results.
ok $d = MyTest::MultiTo->new, "Construct another MultiTo object";
is_deeply [$d->bar(1)], [[1], [1]], "Check return array";
is_deeply scalar $d->bar(1), [1, 1], "Check return arrayref";
MULTITOAS: {
package MyTest::MultiToAs;
sub new { bless { foo => MyTest::Foo->new, bat => MyTest::Foo->new } }
use Class::Delegator
send => 'bar_try',
to => ['{foo}', '{bat}'],
as => [qw(bar try)],
;
}
can_ok 'MyTest::MultiToAs' => 'bar_try';
ok $d = MyTest::MultiToAs->new, "Construct new MultiToAs object";
is $d->{foo}->bar, undef, "Check that foo's bar is undef";
is $d->{foo}->try, undef, "Check that foo's try is undef";
is $d->{bat}->bar, undef, "Check that bat's bar is undef";
is $d->{bat}->try, undef, "Check that bat's try is undef";
ok $d->bar_try('yo'), "Set bar_try to 'yo'";
is $d->{foo}->bar, 'yo', "Check that foo's bar is now 'yo'";
is $d->{foo}->try, undef, "Check that foo's try is still undef";
is $d->{bat}->bar, undef, "Check that bat's bar is still undef";
is $d->{bat}->try, 'yo', "Check that bat's try is now 'yow'";
ERRORS: {
package MyTest::Errors;
use Test::More;
sub new { bless {} }
sub try {}
eval { Class::Delegator->import(foo => 'bar') };
ok my $err = $@, "Catch 'missing send' exception";
like $err, qr/Expected "send => <method spec>" but found "foo => bar"/,
"Caught correct 'missing send' exception";
eval { Class::Delegator->import(send => 'foo', foo => 'bar') };
ok $err = $@, "Catch 'missing to' exception";
like $err, qr/Expected "to => <attribute spec>" but found "foo => bar"/,
"Caught correct 'missing to' exception";
eval { Class::Delegator->import(send => [], to => []) };
ok $err = $@, "Catch 'double array' exception";
like $err, qr/Cannot specify both "send" and "to" as arrays/,
"Caught correct 'double array' exception";
eval { Class::Delegator->import(send => 'foo', to => [1], as => []) };
ok $err = $@, "Catch 'different length' exception";
like $err, qr/Arrays specified for "to" and "as" must be the same length/,
"Caught correct 'different length' exception";
eval { Class::Delegator->import(send => 'foo', to => [1], as => 1) };
ok $err = $@, "Catch 'scalar as' exception";
like $err, qr/Cannot specify "as" as a scalar if "to" is an array/,
"Caught correct 'scalar as' exception";
}
LINENOS: {
package MyTest::LineNos;
use Test::More;
sub new { bless {} }
sub try { die 'Ow' }
# Fake out line numbering so that we can just use one in the test.
#line 248 t/base.t
use Class::Delegator
send => 'hey', # Line 251, error should be from here.
to => 'try'
;
# Line 253, sometimes error is here. No idea why.
}
ok my $try = MyTest::LineNos->new, 'Create new LineNos object';
use Carp;
local $SIG{__DIE__} = \&confess;
eval { $try->hey };
ok my $err = $@, 'Should Catch exception';
my $fn = 't/base.t';
like $err, qr/called (?:at\s+$fn|$fn\s+at)\s+line/,
'The exception should have this file name in it';
like $err, qr/MyTest::LineNos::hey/,
'The exception should have the name of the delegating method';