1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
#!/usr/bin/perl
use strict;
use warnings;
use lib 't/lib';
use MyTests tests => 51;
{
package FooRole;
our $VERSION = 23;
use Role::Basic allow => 'TestMethods';
use TestMethods qw(bar baz);
sub goo {'FooRole::goo'}
sub foo {'FooRole::foo'}
}
{
package BarRole;
use Role::Basic;;
sub woot {'BarRole::woot'}
}
{
package BarClass;
sub boo {'BarClass::boo'}
sub foo {'BarClass::foo'} # << the role overrides this ...
}
{
package FooClass;
use Role::Basic 'with';
use base 'BarClass';
sub new { bless {} => shift }
eval { with 'FooRole' => { -version => 42 }; 1 }
or my $error = $@;
::like $error, qr/FooRole version 42 required--this is only version 23/,
'applying role with unsatisfied version requirement';
$error = '';
eval { with 'FooRole' => { -version => 13 }; 1 }
or $error = $@;
::ok !$error, 'applying role with satisfied version requirement';
sub goo {'FooClass::goo'} # << overrides the one from the role ...
}
{
package FooBarClass;
use Role::Basic 'with';
use base 'FooClass';
with 'FooRole', 'BarRole';
}
foreach my $method_name (qw(bar baz foo boo goo)) {
can_ok 'FooBarClass', $method_name;
}
can_ok( 'FooClass', 'DOES' );
ok( FooClass->DOES('FooRole'), '... the FooClass DOES FooRole' );
ok( !FooClass->DOES('BarRole'), '... the FooClass DOES not do BarRole' );
ok( !FooClass->DOES('OtherRole'), '... the FooClass DOES not do OtherRole' );
can_ok( 'FooBarClass', 'DOES' );
ok( FooBarClass->DOES('FooRole'), '... the FooClass DOES FooRole' );
ok( FooBarClass->DOES('BarRole'), '... the FooBarClass DOES FooBarRole' );
ok( !FooBarClass->DOES('OtherRole'),
'... the FooBarClass DOES not do OtherRole' );
my $foo = FooClass->new();
isa_ok( $foo, 'FooClass' );
my $foobar = FooBarClass->new();
isa_ok( $foobar, 'FooBarClass' );
is( $foo->goo, 'FooClass::goo', '... got the right value of goo' );
is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' );
is( $foo->boo, 'BarClass::boo',
'... got the right value from ->boo' );
is( $foobar->boo, 'BarClass::boo',
'... got the right value from ->boo (double wrapped)' );
foreach my $foo ( $foo, $foobar ) {
can_ok( $foo, 'DOES' );
ok( $foo->DOES('FooRole'), '... an instance of FooClass DOES FooRole' );
ok( !$foo->DOES('OtherRole'),
'... and instance of FooClass DOES not do OtherRole' );
can_ok( $foobar, 'DOES' );
ok( $foobar->DOES('FooRole'),
'... an instance of FooBarClass DOES FooRole' );
ok( $foobar->DOES('BarRole'),
'... an instance of FooBarClass DOES BarRole' );
ok( !$foobar->DOES('OtherRole'),
'... and instance of FooBarClass DOES not do OtherRole' );
for my $method (qw/bar baz foo boo goo/) {
ok $foo->can($method), "$foo should be able to do $method";
}
is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
}
|
