Commit | Line | Data |
8c9d74e7 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Scalar::Util 'isweak'; |
7 | |
c26a8868 |
8 | use Test::More tests => 43; |
8c9d74e7 |
9 | use Test::Exception; |
10 | |
11 | BEGIN { |
12 | use_ok('Moose'); |
13 | } |
14 | |
15 | { |
16 | package Foo; |
8c9d74e7 |
17 | use Moose; |
18 | |
19 | has 'bar' => (is => 'rw', |
ab76842e |
20 | isa => 'Maybe[Bar]', |
8c9d74e7 |
21 | trigger => sub { |
22 | my ($self, $bar) = @_; |
23 | $bar->foo($self) if defined $bar; |
24 | }); |
25 | |
26 | has 'baz' => (writer => 'set_baz', |
27 | reader => 'get_baz', |
28 | isa => 'Baz', |
29 | trigger => sub { |
30 | my ($self, $baz) = @_; |
31 | $baz->foo($self); |
32 | }); |
33 | |
34 | |
35 | package Bar; |
8c9d74e7 |
36 | use Moose; |
37 | |
38 | has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); |
39 | |
40 | package Baz; |
8c9d74e7 |
41 | use Moose; |
42 | |
43 | has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); |
44 | } |
45 | |
46 | { |
47 | my $foo = Foo->new; |
48 | isa_ok($foo, 'Foo'); |
49 | |
50 | my $bar = Bar->new; |
51 | isa_ok($bar, 'Bar'); |
52 | |
53 | my $baz = Baz->new; |
54 | isa_ok($baz, 'Baz'); |
55 | |
56 | lives_ok { |
57 | $foo->bar($bar); |
58 | } '... did not die setting bar'; |
59 | |
60 | is($foo->bar, $bar, '... set the value foo.bar correctly'); |
61 | is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); |
62 | |
63 | ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); |
64 | |
65 | lives_ok { |
66 | $foo->bar(undef); |
67 | } '... did not die un-setting bar'; |
68 | |
69 | is($foo->bar, undef, '... set the value foo.bar correctly'); |
70 | is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); |
71 | |
72 | # test the writer |
73 | |
74 | lives_ok { |
75 | $foo->set_baz($baz); |
76 | } '... did not die setting baz'; |
77 | |
78 | is($foo->get_baz, $baz, '... set the value foo.baz correctly'); |
79 | is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); |
80 | |
81 | ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); |
82 | } |
83 | |
84 | { |
85 | my $bar = Bar->new; |
86 | isa_ok($bar, 'Bar'); |
87 | |
88 | my $baz = Baz->new; |
89 | isa_ok($baz, 'Baz'); |
90 | |
91 | my $foo = Foo->new(bar => $bar, baz => $baz); |
92 | isa_ok($foo, 'Foo'); |
93 | |
94 | is($foo->bar, $bar, '... set the value foo.bar correctly'); |
95 | is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); |
96 | |
97 | ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); |
98 | |
99 | is($foo->get_baz, $baz, '... set the value foo.baz correctly'); |
100 | is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); |
101 | |
102 | ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); |
103 | } |
104 | |
c26a8868 |
105 | # before/around/after triggers |
106 | { |
107 | package Fweet; |
108 | use Moose; |
109 | |
110 | has calls => ( |
111 | is => 'ro', |
112 | isa => 'ArrayRef', |
113 | default => sub {[]}, |
114 | ); |
115 | |
116 | sub called { |
117 | my ($self, $str, @args) = @_; |
118 | push(@{$self->calls}, $str); |
119 | } |
120 | |
121 | has noise => ( |
122 | is => 'rw', |
123 | default => 'Sartak', |
124 | trigger => { |
125 | before => sub { |
126 | $_[0]->called('before'); |
127 | }, |
128 | around => sub { |
129 | my ($ori, $self, $val, @whatever) = @_; |
130 | $self->called('around'); |
131 | $ori->($self, $val.'-diddly', @whatever); |
132 | }, |
133 | after => sub { |
134 | $_[0]->called('after'); |
135 | }, |
136 | }, |
137 | ); |
138 | } |
139 | |
140 | sub fancy_trigger_tests |
141 | { |
142 | my $type = shift; |
143 | my $blah; |
144 | ::lives_ok { |
145 | $blah = Fweet->new; |
146 | } "... $type constructor"; |
147 | my $expected_calls = [qw(before around after)]; |
148 | |
149 | is_deeply($blah->calls, $expected_calls, "$type default triggered"); |
150 | is($blah->noise, 'Sartak-diddly', "$type default around modified value"); |
151 | @{$blah->calls} = (); |
152 | |
153 | $blah->noise('argle-bargle'); |
154 | is_deeply($blah->calls, $expected_calls, "$type set triggered"); |
155 | is($blah->noise, 'argle-bargle-diddly', "$type set around modified value"); |
156 | |
157 | $blah = Fweet->new(noise => 'woot'); |
158 | is_deeply($blah->calls, $expected_calls, "$type constructor triggered"); |
159 | is($blah->noise, 'woot-diddly', "$type constructor around modified value"); |
160 | } |
161 | |
162 | { |
163 | fancy_trigger_tests('normal'); |
164 | ::lives_ok { |
165 | Fweet->meta->make_immutable; |
166 | } '... make_immutable works'; |
167 | fancy_trigger_tests('inline'); |
168 | } |
169 | |
7eaef7ad |
170 | # some errors |
171 | |
172 | { |
173 | package Bling; |
7eaef7ad |
174 | use Moose; |
c26a8868 |
175 | |
176 | ::dies_ok { |
177 | has('bling' => (is => 'rw', trigger => {FAIL => sub {}})); |
178 | } '... hash specifier has to be before/around/after'; |
179 | |
180 | ::dies_ok { |
181 | has('bling' => (is => 'rw', trigger => {around => 'FAIL'})); |
182 | } '... hash specifier value must be CODE ref'; |
7eaef7ad |
183 | |
184 | ::dies_ok { |
7eaef7ad |
185 | has('bling' => (is => 'rw', trigger => 'Fail')); |
c26a8868 |
186 | } '... a trigger must be a CODE or HASH ref'; |
7eaef7ad |
187 | |
188 | ::dies_ok { |
189 | has('bling' => (is => 'rw', trigger => [])); |
c26a8868 |
190 | } '... a trigger must be a CODE or HASH ref'; |
7eaef7ad |
191 | } |
192 | |
193 | |