Commit | Line | Data |
78cd1d3b |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
bbd2fe69 |
6 | use Test::More tests => 39; |
78cd1d3b |
7 | use Test::Exception; |
8 | |
9 | BEGIN { |
10 | use_ok('Moose::Role'); |
11 | } |
12 | |
13 | { |
14 | package FooRole; |
15 | use strict; |
16 | use warnings; |
17 | use Moose::Role; |
18 | |
19 | has 'bar' => (is => 'rw', isa => 'FooClass'); |
20 | has 'baz' => (is => 'ro'); |
21 | |
22 | sub goo { 'FooRole::goo' } |
23 | sub foo { 'FooRole::foo' } |
24 | |
25 | override 'boo' => sub { 'FooRole::boo -> ' . super() }; |
26 | |
27 | around 'blau' => sub { |
28 | my $c = shift; |
29 | 'FooRole::blau -> ' . $c->(); |
30 | }; |
31 | |
32 | package BarClass; |
33 | use strict; |
34 | use warnings; |
35 | use Moose; |
36 | |
37 | sub boo { 'BarClass::boo' } |
38 | sub foo { 'BarClass::foo' } # << the role overrides this ... |
39 | |
40 | package FooClass; |
41 | use strict; |
42 | use warnings; |
43 | use Moose; |
44 | |
45 | extends 'BarClass'; |
46 | with 'FooRole'; |
47 | |
48 | sub blau { 'FooClass::blau' } |
49 | |
50 | sub goo { 'FooClass::goo' } # << overrides the one from the role ... |
51 | } |
52 | |
53 | my $foo_class_meta = FooClass->meta; |
54 | isa_ok($foo_class_meta, 'Moose::Meta::Class'); |
55 | |
bbd2fe69 |
56 | dies_ok { |
57 | $foo_class_meta->does_role() |
58 | } '... does_role requires a role name'; |
59 | |
60 | dies_ok { |
61 | $foo_class_meta->apply_role() |
62 | } '... apply_role requires a role'; |
63 | |
64 | dies_ok { |
65 | $foo_class_meta->apply_role(bless({} => 'Fail')) |
66 | } '... apply_role requires a role'; |
67 | |
ef333f17 |
68 | ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole'); |
69 | ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole'); |
70 | |
78cd1d3b |
71 | foreach my $method_name (qw(bar baz foo boo blau goo)) { |
72 | ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name); |
73 | } |
74 | |
75 | foreach my $attr_name (qw(bar baz)) { |
76 | ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name); |
77 | } |
78 | |
ef333f17 |
79 | can_ok('FooClass', 'does'); |
80 | ok(FooClass->does('FooRole'), '... the FooClass does FooRole'); |
81 | ok(!FooClass->does('OtherRole'), '... the FooClass does not do OtherRole'); |
82 | |
78cd1d3b |
83 | my $foo = FooClass->new(); |
84 | isa_ok($foo, 'FooClass'); |
85 | |
ef333f17 |
86 | can_ok($foo, 'does'); |
87 | ok($foo->does('FooRole'), '... an instance of FooClass does FooRole'); |
88 | ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole'); |
89 | |
78cd1d3b |
90 | can_ok($foo, 'bar'); |
91 | can_ok($foo, 'baz'); |
92 | can_ok($foo, 'foo'); |
93 | can_ok($foo, 'boo'); |
94 | can_ok($foo, 'goo'); |
95 | can_ok($foo, 'blau'); |
96 | |
97 | is($foo->foo, 'FooRole::foo', '... got the right value of foo'); |
98 | is($foo->goo, 'FooClass::goo', '... got the right value of goo'); |
99 | |
100 | ok(!defined($foo->baz), '... $foo->baz is undefined'); |
101 | ok(!defined($foo->bar), '... $foo->bar is undefined'); |
102 | |
103 | dies_ok { |
104 | $foo->baz(1) |
105 | } '... baz is a read-only accessor'; |
106 | |
107 | dies_ok { |
108 | $foo->bar(1) |
109 | } '... bar is a read-write accessor with a type constraint'; |
110 | |
111 | my $foo2 = FooClass->new(); |
112 | isa_ok($foo2, 'FooClass'); |
113 | |
114 | lives_ok { |
115 | $foo->bar($foo2) |
116 | } '... bar is a read-write accessor with a type constraint'; |
117 | |
118 | is($foo->bar, $foo2, '... got the right value for bar now'); |
119 | |
120 | is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo'); |
121 | is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); |
122 | |