It Works, *AND* Its Fast(er)
[gitmo/Moose.git] / t / 042_apply_role.t
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 39;
7 use Test::Exception;
8
9 BEGIN {  
10     use_ok('Moose::Role');               
11 }
12
13 {
14     package FooRole;
15     use Moose::Role;
16     
17     has 'bar' => (is => 'rw', isa => 'FooClass');
18     has 'baz' => (is => 'ro');    
19     
20     sub goo { 'FooRole::goo' }
21     sub foo { 'FooRole::foo' }
22     
23     override 'boo' => sub { 'FooRole::boo -> ' . super() };   
24     
25     around 'blau' => sub {  
26         my $c = shift;
27         'FooRole::blau -> ' . $c->();
28     }; 
29
30 }{
31     package BarClass;
32     use Moose;
33     
34     sub boo { 'BarClass::boo' }
35     sub foo { 'BarClass::foo' }  # << the role overrides this ...  
36
37     __PACKAGE__->meta->make_immutable(debug => 0);
38 }{
39     
40     package FooClass;
41     use Moose;
42     
43     extends 'BarClass';
44        with 'FooRole';
45     
46     sub blau { 'FooClass::blau' }
47
48     sub goo { 'FooClass::goo' }  # << overrides the one from the role ... 
49     
50     __PACKAGE__->meta->make_immutable(debug => 0);
51 }
52
53 my $foo_class_meta = FooClass->meta;
54 isa_ok($foo_class_meta, 'Moose::Meta::Class');
55
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
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
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
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
83 my $foo = FooClass->new();
84 isa_ok($foo, 'FooClass');
85
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
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