Commit | Line | Data |
78cd1d3b |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
dfc199d4 |
6 | use Test::More tests => 86; |
78cd1d3b |
7 | use Test::Exception; |
8 | |
78cd1d3b |
9 | { |
10 | package FooRole; |
78cd1d3b |
11 | use Moose::Role; |
12 | |
13 | has 'bar' => (is => 'rw', isa => 'FooClass'); |
14 | has 'baz' => (is => 'ro'); |
15 | |
16 | sub goo { 'FooRole::goo' } |
17 | sub foo { 'FooRole::foo' } |
0558683c |
18 | |
19 | override 'boo' => sub { 'FooRole::boo -> ' . super() }; |
20 | |
21 | around 'blau' => sub { |
22 | my $c = shift; |
23 | 'FooRole::blau -> ' . $c->(); |
24 | }; |
78cd1d3b |
25 | |
8ecb1fa0 |
26 | }{ |
3f562dd9 |
27 | package BarRole; |
28 | use Moose::Role; |
29 | sub woot { 'BarRole::woot' } |
30 | |
31 | }{ |
78cd1d3b |
32 | package BarClass; |
78cd1d3b |
33 | use Moose; |
34 | |
35 | sub boo { 'BarClass::boo' } |
36 | sub foo { 'BarClass::foo' } # << the role overrides this ... |
8ecb1fa0 |
37 | |
5a3217de |
38 | __PACKAGE__->meta->make_immutable(debug => 0); |
8ecb1fa0 |
39 | }{ |
78cd1d3b |
40 | |
41 | package FooClass; |
78cd1d3b |
42 | use Moose; |
43 | |
44 | extends 'BarClass'; |
45 | with 'FooRole'; |
0558683c |
46 | |
fb1e11d5 |
47 | sub blau { 'FooClass::blau' } # << the role wraps this ... |
78cd1d3b |
48 | |
49 | sub goo { 'FooClass::goo' } # << overrides the one from the role ... |
8ecb1fa0 |
50 | |
5a3217de |
51 | __PACKAGE__->meta->make_immutable(debug => 0); |
3f562dd9 |
52 | }{ |
53 | |
54 | package FooBarClass; |
55 | use Moose; |
56 | |
57 | extends 'FooClass'; |
58 | with 'FooRole', 'BarRole'; |
78cd1d3b |
59 | } |
60 | |
61 | my $foo_class_meta = FooClass->meta; |
62 | isa_ok($foo_class_meta, 'Moose::Meta::Class'); |
63 | |
3f562dd9 |
64 | my $foobar_class_meta = FooBarClass->meta; |
65 | isa_ok($foobar_class_meta, 'Moose::Meta::Class'); |
66 | |
bbd2fe69 |
67 | dies_ok { |
68 | $foo_class_meta->does_role() |
69 | } '... does_role requires a role name'; |
70 | |
71 | dies_ok { |
72 | $foo_class_meta->apply_role() |
73 | } '... apply_role requires a role'; |
74 | |
75 | dies_ok { |
76 | $foo_class_meta->apply_role(bless({} => 'Fail')) |
77 | } '... apply_role requires a role'; |
78 | |
ef333f17 |
79 | ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole'); |
80 | ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole'); |
81 | |
3f562dd9 |
82 | ok($foobar_class_meta->does_role('FooRole'), '... the FooBarClass->meta does_role FooRole'); |
83 | ok($foobar_class_meta->does_role('BarRole'), '... the FooBarClass->meta does_role BarRole'); |
84 | ok(!$foobar_class_meta->does_role('OtherRole'), '... the FooBarClass->meta !does_role OtherRole'); |
85 | |
0558683c |
86 | foreach my $method_name (qw(bar baz foo boo blau goo)) { |
78cd1d3b |
87 | ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name); |
3f562dd9 |
88 | ok($foobar_class_meta->has_method($method_name), '... FooBarClass has the method ' . $method_name); |
78cd1d3b |
89 | } |
90 | |
3f562dd9 |
91 | ok(!$foo_class_meta->has_method('woot'), '... FooClass lacks the method woot'); |
92 | ok($foobar_class_meta->has_method('woot'), '... FooBarClass has the method woot'); |
93 | |
78cd1d3b |
94 | foreach my $attr_name (qw(bar baz)) { |
95 | ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name); |
3f562dd9 |
96 | ok($foobar_class_meta->has_attribute($attr_name), '... FooBarClass has the attribute ' . $attr_name); |
78cd1d3b |
97 | } |
98 | |
ef333f17 |
99 | can_ok('FooClass', 'does'); |
100 | ok(FooClass->does('FooRole'), '... the FooClass does FooRole'); |
3f562dd9 |
101 | ok(!FooClass->does('BarRole'), '... the FooClass does not do BarRole'); |
ef333f17 |
102 | ok(!FooClass->does('OtherRole'), '... the FooClass does not do OtherRole'); |
103 | |
3f562dd9 |
104 | can_ok('FooBarClass', 'does'); |
105 | ok(FooBarClass->does('FooRole'), '... the FooClass does FooRole'); |
106 | ok(FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole'); |
107 | ok(!FooBarClass->does('OtherRole'), '... the FooBarClass does not do OtherRole'); |
108 | |
78cd1d3b |
109 | my $foo = FooClass->new(); |
110 | isa_ok($foo, 'FooClass'); |
111 | |
3f562dd9 |
112 | my $foobar = FooBarClass->new(); |
113 | isa_ok($foobar, 'FooBarClass'); |
114 | |
fb1e11d5 |
115 | is($foo->goo, 'FooClass::goo', '... got the right value of goo'); |
116 | is($foobar->goo, 'FooRole::goo', '... got the right value of goo'); |
ef333f17 |
117 | |
fb1e11d5 |
118 | is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo'); |
119 | is($foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', '... got the right value from ->boo (double wrapped)'); |
3f562dd9 |
120 | |
fb1e11d5 |
121 | is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); |
122 | is($foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); |
78cd1d3b |
123 | |
fb1e11d5 |
124 | foreach my $foo ($foo, $foobar) { |
125 | can_ok($foo, 'does'); |
126 | ok($foo->does('FooRole'), '... an instance of FooClass does FooRole'); |
127 | ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole'); |
78cd1d3b |
128 | |
fb1e11d5 |
129 | can_ok($foobar, 'does'); |
130 | ok($foobar->does('FooRole'), '... an instance of FooBarClass does FooRole'); |
131 | ok($foobar->does('BarRole'), '... an instance of FooBarClass does BarRole'); |
132 | ok(!$foobar->does('OtherRole'), '... and instance of FooBarClass does not do OtherRole'); |
78cd1d3b |
133 | |
fb1e11d5 |
134 | for my $method (qw/bar baz foo boo goo blau/) { |
135 | can_ok($foo, $method); |
136 | } |
78cd1d3b |
137 | |
fb1e11d5 |
138 | is($foo->foo, 'FooRole::foo', '... got the right value of foo'); |
78cd1d3b |
139 | |
fb1e11d5 |
140 | ok(!defined($foo->baz), '... $foo->baz is undefined'); |
141 | ok(!defined($foo->bar), '... $foo->bar is undefined'); |
78cd1d3b |
142 | |
fb1e11d5 |
143 | dies_ok { |
144 | $foo->baz(1) |
145 | } '... baz is a read-only accessor'; |
78cd1d3b |
146 | |
fb1e11d5 |
147 | dies_ok { |
148 | $foo->bar(1) |
149 | } '... bar is a read-write accessor with a type constraint'; |
78cd1d3b |
150 | |
fb1e11d5 |
151 | my $foo2 = FooClass->new(); |
152 | isa_ok($foo2, 'FooClass'); |
06b30515 |
153 | |
fb1e11d5 |
154 | lives_ok { |
155 | $foo->bar($foo2) |
156 | } '... bar is a read-write accessor with a type constraint'; |
157 | |
158 | is($foo->bar, $foo2, '... got the right value for bar now'); |
159 | } |