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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
{
package FooRole;
use Moose::Role;
our $VERSION = 23;
has 'bar' => ( is => 'rw', isa => 'FooClass' );
has 'baz' => ( is => 'ro' );
sub goo {'FooRole::goo'}
sub foo {'FooRole::foo'}
override 'boo' => sub { 'FooRole::boo -> ' . super() };
around 'blau' => sub {
my $c = shift;
'FooRole::blau -> ' . $c->();
};
}
{
package BarRole;
use Moose::Role;
sub woot {'BarRole::woot'}
}
{
package BarClass;
use Moose;
sub boo {'BarClass::boo'}
sub foo {'BarClass::foo'} # << the role overrides this ...
}
{
package FooClass;
use Moose;
extends 'BarClass';
::throws_ok { with 'FooRole' => { -version => 42 } }
qr/FooRole version 42 required--this is only version 23/,
'applying role with unsatisfied version requirement';
::lives_ok { with 'FooRole' => { -version => 13 } }
'applying role with satisfied version requirement';
sub blau {'FooClass::blau'} # << the role wraps this ...
sub goo {'FooClass::goo'} # << overrides the one from the role ...
}
{
package FooBarClass;
use Moose;
extends 'FooClass';
with 'FooRole', 'BarRole';
}
my $foo_class_meta = FooClass->meta;
isa_ok( $foo_class_meta, 'Moose::Meta::Class' );
my $foobar_class_meta = FooBarClass->meta;
isa_ok( $foobar_class_meta, 'Moose::Meta::Class' );
dies_ok {
$foo_class_meta->does_role();
}
'... does_role requires a role name';
dies_ok {
$foo_class_meta->add_role();
}
'... apply_role requires a role';
dies_ok {
$foo_class_meta->add_role( bless( {} => 'Fail' ) );
}
'... apply_role requires a role';
ok( $foo_class_meta->does_role('FooRole'),
'... the FooClass->meta does_role FooRole' );
ok( !$foo_class_meta->does_role('OtherRole'),
'... the FooClass->meta !does_role OtherRole' );
ok( $foobar_class_meta->does_role('FooRole'),
'... the FooBarClass->meta does_role FooRole' );
ok( $foobar_class_meta->does_role('BarRole'),
'... the FooBarClass->meta does_role BarRole' );
ok( !$foobar_class_meta->does_role('OtherRole'),
'... the FooBarClass->meta !does_role OtherRole' );
foreach my $method_name (qw(bar baz foo boo blau goo)) {
ok( $foo_class_meta->has_method($method_name),
'... FooClass has the method ' . $method_name );
ok( $foobar_class_meta->has_method($method_name),
'... FooBarClass has the method ' . $method_name );
}
ok( !$foo_class_meta->has_method('woot'),
'... FooClass lacks the method woot' );
ok( $foobar_class_meta->has_method('woot'),
'... FooBarClass has the method woot' );
foreach my $attr_name (qw(bar baz)) {
ok( $foo_class_meta->has_attribute($attr_name),
'... FooClass has the attribute ' . $attr_name );
ok( $foobar_class_meta->has_attribute($attr_name),
'... FooBarClass has the attribute ' . $attr_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, 'FooRole::boo -> BarClass::boo',
'... got the right value from ->boo' );
is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
'... got the right value from ->boo (double wrapped)' );
is( $foo->blau, 'FooRole::blau -> FooClass::blau',
'... got the right value from ->blau' );
is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
'... got the right value from ->blau' );
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 blau/) {
can_ok( $foo, $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' );
dies_ok {
$foo->baz(1);
}
'... baz is a read-only accessor';
dies_ok {
$foo->bar(1);
}
'... bar is a read-write accessor with a type constraint';
my $foo2 = FooClass->new();
isa_ok( $foo2, 'FooClass' );
lives_ok {
$foo->bar($foo2);
}
'... bar is a read-write accessor with a type constraint';
is( $foo->bar, $foo2, '... got the right value for bar now' );
}
done_testing;
|
